The Wiert Corner – irregular stream of stuff

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

  • My badges

    Mastodon

  • Twitter Updates

  • My Flickr Stream

    20140508-Delphi-2007--Project-Options--Cannot-Edit-Application-Title-HelpFile-Icon-Theming20140430-Fiddler-Filter-Actions-Button-Run-Filterset-now20140424-VMware-Fusion-6.0.3.-no-reclaimable
    More Photos

  • Pages

  • All categories

  • Enter your email address to subscribe to this blog and receive notifications of new posts by email.

    Join 4,262 other subscribers
«
»

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

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
// 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.

view raw

stGC.pas

hosted with ❤ by GitHub


{*******************************************************}
{ }
{ 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.

view raw

stGCFieldFinder.pas

hosted with ❤ by GitHub


<html>
<head>
<title>Garbage Collector For Delphi Objects and Components</title>
</head>
<body>
<b>Garbage Collector For Delphi Objects and Components</b><br>
<p> </p>
<blockquote class="abstract"><b>Abstract: </b>Automatic memory management
of Delphi objects and components. By Rossen Assenov.</blockquote>
<p> </p>
<p>One of the fundamental questions in object oriented programming is how
the memory management of objects should be done. Different languages
take different approaches. C++ calls the constructor/destructor of
stack allocated objects automaticaly, but for heap allocated objects
you have to do it manually and there is no try..finally statement. In
Java you create the objects when you need them and the garabage collector
takes care of the memory cleanup, but there are no destructors, so you
can not explictly say you don't need an object anymore and there is little
control over the process of garbage collection.<br>
<br>
Delphi provides three ways of object management :<br>
<br>
1. Create/destroy the objects using try..finally.<br>
2. Use TComponent descendants – create a component and
let its owner free it.<br>
3. Interfaces – when the reference count for an interface
becomes 0 the object which implements it is destroyed.<br>
<br>
Interfaces are great for new development – start using
them ! ;) – but sometimes they can be an overhead because there are
two declarations of the same thing. Also, most of the base VCL classes
– TList, TStream, etc. – are not components or interface enabled –
so you have to create/destroy them explicitly.</p>
<h3>THE OBJECT SAFE</h3>
The Delphi help says you shouldn't mix the TComponent
owner approach with the interface memory management, but as always
the forbidden fruit is the sweetest ;). As you'll see it is really
useful to have a TComponent descendant which implements an interface
and at the same time IS reference counted so when it goes out of scope
it frees itself and all the components it owns. We'll extend it so it
keeps a list of TObjects and frees them too.<br>
<br>
Lets name the interface IObjectSafe and the reference counted
TComponent descendent which implements it – TObjectSafe.<br>
<p>Here is the source code for <i>SafeUnit.pas</i> :</p>
<pre class="sourcecode"><code><br><b>unit</b> SafeUnit;<br><br><b>interface</b><br><br><b>uses</b> Classes;<br><br><b>type</b> IObjectSafe = <b>interface</b><br> <b>function</b> Safe : TComponent;<br><br> <b>function</b> New (<b>out</b> aReference <font color="#003399"><i>{: Pointer}</i></font>;<br> <b>const</b> aObject : TObject) : IObjectSafe;<br><br> <b>procedure</b> Guard (<b>const</b> aObject : TObject);<br><br> <b>procedure</b> Dispose (<b>var</b> aReference <font color="#003399"><i>{: Pointer}</i></font>);<br> <b>end</b>;<br><br> IExceptionSafe = <b>interface</b><br> <b>procedure</b> SaveException;<br> <b>end</b>;<br><br><b>function</b> ObjectSafe : IObjectSafe; overload;<br><b>function</b> ObjectSafe (<b>out</b> aObjectSafe : IObjectSafe) : IObjectSafe; overload;<br><b>function</b> ExceptionSafe : IExceptionSafe;<br><br><b>function</b> IsAs (<b>out</b> aReference <font color="#003399"><i>{: Pointer}</i></font>;<br> <b>const</b> aObject : TObject;<br> <b>const</b> aClass : TClass) : Boolean;<br><br><b>implementation</b><br><br><b>uses</b> Windows, SysUtils;<br><br><b>type</b> TExceptionSafe = <b>class</b> (TInterfacedObject, IExceptionSafe)<br> <b>private</b><br> FMessages : <b>String</b>;<br> <b>public</b><br> <b>destructor</b> Destroy; override;<br><br> <b>procedure</b> SaveException;<br> <b>end</b>;<br><br> TInterfacedComponent = <b>class</b> (TComponent)<br> <b>private</b><br> FRefCount : Integer;<br> <b>protected</b><br> <b>function</b> _AddRef : Integer; <b>stdcall</b>;<br> <b>function</b> _Release : Integer; <b>stdcall</b>;<br> <b>public</b><br> <b>procedure</b> BeforeDestruction; override;<br> <b>end</b>;<br><br> TAddObjectMethod = <b>procedure</b> (<b>const</b> aObject : TObject) <b>of</b> <b>object</b>;<br><br> TObjectSafe = <b>class</b> (TInterfacedComponent, IObjectSafe)<br> <b>private</b><br> FObjects : <b>array</b> <b>of</b> TObject;<br> FEmptySlots : <b>array</b> <b>of</b> Integer;<br> AddObject : TAddObjectMethod;<br><br> <b>procedure</b> AddObjectAtEndOfList (<b>const</b> aObject : TObject);<br> <b>procedure</b> AddObjectInEmptySlot (<b>const</b> aObject : TObject);<br><br> <b>procedure</b> RemoveObject (<b>const</b> aObject : TObject);<br> <b>public</b><br> <b>constructor</b> Create (aOwner : TComponent); override;<br> <b>destructor</b> Destroy; override;<br><br> <b>function</b> Safe : TComponent;<br> <b>function</b> New (<b>out</b> aReference;<br> <b>const</b> aObject : TObject) : IObjectSafe;<br> <b>procedure</b> Guard (<b>const</b> aObject : TObject);<br> <b>procedure</b> Dispose (<b>var</b> aReference) ;<br> <b>end</b>;<br><br><b>function</b> TInterfacedComponent._AddRef : Integer;<br><b>begin</b><br> Result := InterlockedIncrement (FRefCount);<br><b>end</b>;<br><br><b>function</b> TInterfacedComponent._Release : Integer;<br><b>begin</b><br> Result := InterlockedDecrement (FRefCount);<br><br> <b>if</b> Result = 0<br> <b>then</b> Destroy;<br><b>end</b>;<br><br><b>procedure</b> TInterfacedComponent.BeforeDestruction;<br><b>begin</b><br> <b>if</b> FRefCount &lt;&gt; 0<br> <b>then</b> <b>raise</b> Exception.Create (ClassName + <font color="#9933cc">' not freed correctly'</font>);<br><b>end</b>;<br><br><font color="#003399"><i>{ TObjectSafe }</i></font><br><br><b>constructor</b> TObjectSafe.Create (aOwner : TComponent);<br><b>begin</b><br> <b>inherited</b> Create (aOwner);<br><br> AddObject := AddObjectAtEndOfList;<br><b>end</b>;<br><br><b>destructor</b> TObjectSafe.Destroy;<br> <b>var</b> aIndex : Integer;<br> aComponent : TComponent;<br><b>begin</b><br> <b>with</b> ExceptionSafe <b>do</b><br> <b>begin</b><br> <b>for</b> aIndex := High (FObjects) <b>downto</b> Low (FObjects) <b>do</b><br> <b>try</b><br> FObjects [aIndex].Free;<br> <b>except</b><br> SaveException;<br> <b>end</b>;<br><br> <b>for</b> aIndex := Pred (ComponentCount) <b>downto</b> 0 <b>do</b><br> <b>try</b><br> aComponent := Components [aIndex];<br> <b>try</b><br> RemoveComponent (aComponent);<br> <b>finally</b><br> aComponent.Free;<br> <b>end</b>;<br> <b>except</b><br> SaveException;<br> <b>end</b>;<br><br> <b>try</b><br> <b>inherited</b> Destroy;<br> <b>except</b><br> SaveException;<br> <b>end</b>;<br> <b>end</b>;<br><b>end</b>;<br><br><b>function</b> TObjectSafe.Safe : TComponent;<br><b>begin</b><br> Result := Self;<br><b>end</b>;<br><br><b>procedure</b> TObjectSafe.AddObjectAtEndOfList (<b>const</b> aObject : TObject);<br><b>begin</b><br> SetLength (FObjects, Succ (Length (FObjects)));<br> FObjects [High (FObjects)] := aObject;<br><b>end</b>;<br><br><b>procedure</b> TObjectSafe.AddObjectInEmptySlot (<b>const</b> aObject : TObject);<br><b>begin</b><br> FObjects [FEmptySlots [High (FEmptySlots)]] := aObject;<br> SetLength (FEmptySlots, High (FEmptySlots));<br><br> <b>if</b> Length (FEmptySlots) = 0<br> <b>then</b> AddObject := AddObjectAtEndOfList;<br><b>end</b>;<br><br><b>procedure</b> TObjectSafe.RemoveObject (<b>const</b> aObject : TObject);<br> <b>var</b> aIndex : Integer;<br><b>begin</b><br> <b>for</b> aIndex := High (FObjects) <b>downto</b> Low (FObjects) <b>do</b><br> <b>begin</b><br> <b>if</b> FObjects [aIndex] = aObject <b>then</b><br> <b>begin</b><br> FObjects [aIndex] := <b>Nil</b>;<br><br> SetLength (FEmptySlots, Succ (Length (FEmptySlots)));<br> FEmptySlots [High (FEmptySlots)] := aIndex;<br> AddObject := AddObjectInEmptySlot;<br> <br> Exit;<br> <b>end</b>;<br> <b>end</b>;<br><b>end</b>;<br><br><b>procedure</b> TObjectSafe.Dispose (<b>var</b> aReference);<br><b>begin</b><br> <b>try</b><br> <b>try</b><br> <b>if</b> TObject (aReference) <b>is</b> TComponent<br> <b>then</b> RemoveComponent (TComponent (TObject (aReference)))<br> <b>else</b> RemoveObject (TObject (aReference));<br> <b>finally</b><br> TObject (aReference).Free;<br> <b>end</b>;<br> <b>finally</b><br> TObject (aReference) := <b>Nil</b>;<br> <b>end</b>;<br><b>end</b>;<br><br><b>procedure</b> TObjectSafe.Guard (<b>const</b> aObject : TObject);<br><b>begin</b><br> <b>try</b><br> <b>if</b> aObject <b>is</b> TComponent <b>then</b><br> <b>begin</b><br> <b>if</b> TComponent (aObject).Owner &lt;&gt; Self<br> <b>then</b> InsertComponent (TComponent (aObject));<br> <b>end</b><br> <b>else</b> AddObject (aObject);<br> <b>except</b><br> aObject.Free;<br><br> <b>raise</b>;<br> <b>end</b>;<br><b>end</b>;<br><br><b>function</b> TObjectSafe.New (<b>out</b> aReference; <b>const</b> aObject : TObject) : IObjectSafe;<br><b>begin</b><br> <b>try</b><br> Guard (aObject);<br><br> TObject (aReference) := aObject;<br> <b>except</b><br> TObject (aReference) := <b>Nil</b>;<br><br> <b>raise</b>;<br> <b>end</b>;<br><br> Result := Self;<br><b>end</b>;<br><br><font color="#003399"><i>{ TExceptionSafe }</i></font><br><br><b>destructor</b> TExceptionSafe.Destroy;<br><b>begin</b><br> <b>try</b><br> <b>if</b> Length (FMessages) &gt; 0<br> <b>then</b> <b>raise</b> Exception.Create (FMessages);<br> <b>finally</b><br> <b>try</b> <b>inherited</b> Destroy; <b>except</b> <b>end</b>;<br> <b>end</b>;<br><b>end</b>;<br><br><b>procedure</b> TExceptionSafe.SaveException;<br><b>begin</b><br> <b>try</b><br> <b>if</b> (ExceptObject &lt;&gt; <b>Nil</b>) <b>and</b> (ExceptObject <b>is</b> Exception)<br> <b>then</b> FMessages := FMessages + Exception (ExceptObject).Message + #13#10;<br> <b>except</b><br> <b>end</b>; <br><b>end</b>;<br><br><b>function</b> ExceptionSafe : IExceptionSafe;<br><b>begin</b><br> Result := TExceptionSafe.Create;<br><b>end</b>;<br><br><b>function</b> ObjectSafe : IObjectSafe;<br><b>begin</b><br> Result := TObjectSafe.Create (<b>Nil</b>);<br><b>end</b>;<br><br><b>function</b> ObjectSafe (<b>out</b> aObjectSafe : IObjectSafe) : IObjectSafe; overload;<br><b>begin</b><br> Result := ObjectSafe;<br><br> aObjectSafe := Result;<br><b>end</b>;<br><br><b>function</b> IsAs (<b>out</b> aReference <font color="#003399"><i>{: Pointer}</i></font>;<br> <b>const</b> aObject : TObject;<br> <b>const</b> aClass : TClass) : Boolean;<br><b>begin</b><br> Result := (aObject &lt;&gt; <b>Nil</b>) <b>and</b> (aObject <b>is</b> aClass);<br><br> <b>if</b> Result<br> <b>then</b> TObject (aReference) := aObject;<br><b>end</b>;<br><br><b>end</b>.<br><br></code></pre>
<p>How do you use a safe ? It's pretty simple :<br>
</p>
<pre class="sourcecode"><code><br><b>procedure</b> TestTheSafe;<br><br> <b>var</b> aMyObject : TMyObject;<br> aMyComponent : TMyComponent;<br><br><b>begin</b><br> <b>with</b> ObjectSafe <b>do</b><br> <b>begin</b><br> New (aMyObject, TMyObject.Create);<br><br> <font color="#003399"><i>// or</i></font><br> <font color="#003399"><i>// aMyObject := TMyObject.Create; Guard (aMyObject);</i></font><br> <br> aMyComponent := TMyComponent.Create (Safe);<br> <b>end</b>;<br><b>end</b>;<br><br></code></pre>
<p>Notice the use of the 'with' statement – you can use a safe without
having to declare a local variable for it. When you create a component just
pass the 'safe' component as the owner to the constructor.&nbsp; When the
execution of the code reaches the 'end' of the 'with' statement the reference
count of IObjectSafe will hit 0, the destructor of TObjectSafe will be called
and all the components and objects it owns will be freed. So now you have
the best of both worlds – you can create an object when you need it, be sure
it will be automaticaly destroyed and know exactly when it will happen.<br>
<br>
The 'New'/'Dispose' methods of IObjectSafe use the 'untyped'
pointer type to return a reference to an object – this will cause
exception if you mismatch the types of the reference and the actual
object created (there won't be a memory leak though), but it is flexible
and shorter to type. If you want to play it safe use the 'Guard' function
instead.<br>
<br>
You can also create one IObjectSafe in the constructor
of a complex object which uses a lot of internal objects so you don't
need to explicitly free them&nbsp; in the destructor.<br>
<br>
Take a look at the implementation of the AddObject 'procedure'
inside TObjectSafe. This is a method pointer technique you can use
when you need to do one operation most of the time – add an object
at the end of the array – and some other operation rarely – put an object
into an empty slot – and you don't want to check each time which one
of them to perform.<br>
</p>
<h3>THE EXCEPTION SAFE</h3>
<p>Another useful safe used in the implementation of TObjectSafe is IExceptionSafe.
Many times you need to perform an action over many objects but sometimes
you can get an exception. The usual practice is to write something
like :</p>
<pre class="sourcecode"><code><br><b>for</b> aIndex := 1 <b>to</b> 10 <b>do</b><br><b>try</b><br> <font color="#003399"><i>// do something which might raise an exception</i></font><br><b>except</b><br><b>end</b>;<br><br></code></pre>
<p>and ignore the exceptions, but it's better to remember the exception
messages and show them later.<br>
<br>
That's what IExceptionSafe is used for. It has only one procedure
'SaveException' without parameters – it uses the system function 'ExceptObject'
to get a pointer to the current exception. Create a new ExceptionSafe
interface at the start of the block where you want to remember the exceptions
and when the execution reaches the end of the 'with' statement the destructor
of TExcetionSafe checks if there were any exceptions remembered and raises
a new exception with all of the exception messages :<br>
</p>
<pre class="sourcecode"><code><br><b>with</b> ExceptionSafe <b>do</b><br><b>try</b><br> <b>for</b> aIndex := 1 <b>to</b> 10 <b>do</b><br> <b>try</b><br> <font color="#330099"><i>// do something which might raise an exception</i></font><br> <b>except</b><br> SaveException; <br> <b>end</b>;<br><br> <b>for</b> aIndex := 10 <b>to</b> 20 <b>do<br> try</b><br> </code><code><font color="#330099"><i>// do something which might raise an exception</i></font></code><br><code> <b>except</b><br> SaveException; <br> <b>end</b>;<br><br> </code><code><font color="#330099"><i>// do something which might raise an exception</i></font></code><br><code><b>except</b><br> SaveException;<br><b>end</b>;<br><br></code></pre>
<h3>THE 'IsAs' OPERATOR</h3>
<p>Often you need to check the type of some object and typecast it to a
reference using the 'is' and 'as' operators, like this :</p>
<pre class="sourcecode"><code><br><b>if</b> aSomeObject <b>is</b> TMyObject <b>then</b><br><b>begin</b><br> aMyObject := aSomeObject <b>as</b> TMyObject;<br><br> <font color="#330099"><i>// do something with aMyObject</i></font><br><b>end</b>;<br><br></code></pre>
<p>With the 'IsAs' function you can accomplish all this in just one line
: </p>
<pre class="sourcecode"><code><br><b>if</b> IsAs (aMyObject, aSomeObject, TMyObject) <b>then<br>begin</b><br> <font color="#330099"><i>// do something with aMyObject</i></font><br><b>end</b>;<br><br></code></pre>
<p>As you can see 'untyped' pointer types can be quite handy.</p>
<h3>CONCLUSION</h3>
<p>By using the presented techniques you can greatly simplify the memory
management of Delphi objects/components and make your programs safer.<br>
Suggestions and comments are welcomed — just <a href="mailto:rossen_assenov@yahoo.com">
write me</a>!<br>
The source code is available at <a href="http://codecentral.borland.com/codecentral/ccweb.exe/listing?id=17286"&gt;
CodeCentral</a><br>
</p>
</body>
</html>

view raw

17286_delphigarbagecollector.html

hosted with ❤ by GitHub


// Viewing SafeUit.pas from CC#17286: Garbage Collector for Delphi Objects and Components
unit SafeUnit;
interface
uses Classes;
type IObjectSafe = interface
function Safe : TComponent;
function New (out aReference {: Pointer};
const aObject : TObject) : IObjectSafe;
procedure Guard (const aObject : TObject);
procedure Dispose (var aReference {: Pointer});
end;
IExceptionSafe = interface
procedure SaveException;
end;
function ObjectSafe : IObjectSafe; overload;
function ObjectSafe (out aObjectSafe : IObjectSafe) : IObjectSafe; overload;
function ExceptionSafe : IExceptionSafe;
function IsAs (out aReference {: Pointer};
const aObject : TObject;
const aClass : TClass) : Boolean;
implementation
uses Windows, SysUtils;
type TExceptionSafe = class (TInterfacedObject, IExceptionSafe)
private
FMessages : String;
public
destructor Destroy; override;
procedure SaveException;
end;
TInterfacedComponent = class (TComponent)
private
FRefCount : Integer;
protected
function _AddRef : Integer; stdcall;
function _Release : Integer; stdcall;
public
procedure BeforeDestruction; override;
end;
TAddObjectMethod = procedure (const aObject : TObject) of object;
TObjectSafe = class (TInterfacedComponent, IObjectSafe)
private
FObjects : array of TObject;
FEmptySlots : array of Integer;
AddObject : TAddObjectMethod;
procedure AddObjectAtEndOfList (const aObject : TObject);
procedure AddObjectInEmptySlot (const aObject : TObject);
procedure RemoveObject (const aObject : TObject);
public
constructor Create (aOwner : TComponent); override;
destructor Destroy; override;
function Safe : TComponent;
function New (out aReference;
const aObject : TObject) : IObjectSafe;
procedure Guard (const aObject : TObject);
procedure Dispose (var aReference) ;
end;
function TInterfacedComponent._AddRef : Integer;
begin
Result := InterlockedIncrement (FRefCount);
end;
function TInterfacedComponent._Release : Integer;
begin
Result := InterlockedDecrement (FRefCount);
if Result = 0
then Destroy;
end;
procedure TInterfacedComponent.BeforeDestruction;
begin
if FRefCount <> 0
then raise Exception.Create (ClassName + ' not freed correctly');
end;
{ TObjectSafe }
constructor TObjectSafe.Create (aOwner : TComponent);
begin
inherited Create (aOwner);
AddObject := AddObjectAtEndOfList;
end;
destructor TObjectSafe.Destroy;
var aIndex : Integer;
aComponent : TComponent;
begin
with ExceptionSafe do
begin
for aIndex := High (FObjects) downto Low (FObjects) do
try
FObjects [aIndex].Free;
except
SaveException;
end;
for aIndex := Pred (ComponentCount) downto 0 do
try
aComponent := Components [aIndex];
try
RemoveComponent (aComponent);
finally
aComponent.Free;
end;
except
SaveException;
end;
try
inherited Destroy;
except
SaveException;
end;
end;
end;
function TObjectSafe.Safe : TComponent;
begin
Result := Self;
end;
procedure TObjectSafe.AddObjectAtEndOfList (const aObject : TObject);
begin
SetLength (FObjects, Succ (Length (FObjects)));
FObjects [High (FObjects)] := aObject;
end;
procedure TObjectSafe.AddObjectInEmptySlot (const aObject : TObject);
begin
FObjects [FEmptySlots [High (FEmptySlots)]] := aObject;
SetLength (FEmptySlots, High (FEmptySlots));
if Length (FEmptySlots) = 0
then AddObject := AddObjectAtEndOfList;
end;
procedure TObjectSafe.RemoveObject (const aObject : TObject);
var aIndex : Integer;
begin
for aIndex := High (FObjects) downto Low (FObjects) do
begin
if FObjects [aIndex] = aObject then
begin
FObjects [aIndex] := Nil;
SetLength (FEmptySlots, Succ (Length (FEmptySlots)));
FEmptySlots [High (FEmptySlots)] := aIndex;
AddObject := AddObjectInEmptySlot;
Exit;
end;
end;
end;
procedure TObjectSafe.Dispose (var aReference);
begin
try
try
if TObject (aReference) is TComponent
then RemoveComponent (TComponent (TObject (aReference)))
else RemoveObject (TObject (aReference));
finally
TObject (aReference).Free;
end;
finally
TObject (aReference) := Nil;
end;
end;
procedure TObjectSafe.Guard (const aObject : TObject);
begin
try
if aObject is TComponent then
begin
if TComponent (aObject).Owner <> Self
then InsertComponent (TComponent (aObject));
end
else AddObject (aObject);
except
aObject.Free;
raise;
end;
end;
function TObjectSafe.New (out aReference; const aObject : TObject) : IObjectSafe;
begin
try
Guard (aObject);
TObject (aReference) := aObject;
except
TObject (aReference) := Nil;
raise;
end;
Result := Self;
end;
{ TExceptionSafe }
destructor TExceptionSafe.Destroy;
begin
try
if Length (FMessages) > 0
then raise Exception.Create (FMessages);
finally
try inherited Destroy; except end;
end;
end;
procedure TExceptionSafe.SaveException;
begin
try
if (ExceptObject <> Nil) and (ExceptObject is Exception)
then FMessages := FMessages + Exception (ExceptObject).Message + #13#10;
except
end;
end;
function ExceptionSafe : IExceptionSafe;
begin
Result := TExceptionSafe.Create;
end;
function ObjectSafe : IObjectSafe;
begin
Result := TObjectSafe.Create (Nil);
end;
function ObjectSafe (out aObjectSafe : IObjectSafe) : IObjectSafe; overload;
begin
Result := ObjectSafe;
aObjectSafe := Result;
end;
function IsAs (out aReference {: Pointer};
const aObject : TObject;
const aClass : TClass) : Boolean;
begin
Result := (aObject <> Nil) and (aObject is aClass);
if Result
then TObject (aReference) := aObject;
end;
end.

view raw

SafeUit.pas

hosted with ❤ by GitHub

This entry was posted on 2020/12/30 at 18:00 and is filed under C, C++, Delphi, Development, Software Development. You can follow any responses to this entry through the RSS 2.0 feed. You can leave a response, or trackback from your own site.

Leave a comment

This site uses Akismet to reduce spam. Learn how your comment data is processed.

«
»