A generic pool

Sometimes under some circunstances, there is a heavy object allocation/deallocation which penalizes the performance quite a lot, a way of improving this issue is an object pool (very similar to a database connection pool). Our implementation resides in BB.Pool and defined in this way:

{$M+}

  TObjectPool<T: class, constructor> = class(TPooledObject, IPool<T>)
  private
    FBusy,
    FFree: TList<T>;
    FOnDataNeeded: TNotifyEvent;
    FCurrent: integer;
    FOnReleaseObject: TNotifyEvent;
    FUseGarbage: boolean;
    FTimeOut: cardinal;
    FOnGarbage: TGarbageNotify;
    FOnKillObject: TNotifyEvent;
    FGarbageSleep: cardinal;
    FOnException: TMessageException;
    FCapacity: cardinal;
    FOnLog: TPoolLog;
    FOnGetObject: TNotifyEvent;
    FLock: ILock;
    FOnCreateObject: TNotifyEvent;
    FOwnObjects: boolean;

    function GetFree(aIndex: integer): T;
    function GetItem(aIndex: integer): T;
    procedure SetPooled(aObject: T);
    procedure CheckNull(aObject: T);
    procedure CheckCapacity;
    procedure ClearObject(aObject: T);
  protected
    function CreateClass: T; virtual;
    procedure DoRelease(aObject: T); virtual;
    procedure DoDataNeeded(aObject: T); virtual;
  public
    constructor Create; override;
    destructor Destroy; override;
    procedure Clear; override;
    function Get: T; virtual;
    procedure Release(aObject: T);
    procedure ReleaseAll;
    procedure KillObject(aObject: T; aWaitGarbage: boolean = True);
    function Count: cardinal;
    function Used: integer;
    function NonUsed: integer;
    procedure Grow(aSize: cardinal);

    property FreeItems[index: integer]: T read GetFree;
    property UsedItems[index: integer]: T Read GetItem; default;
  published
    property Capacity: cardinal Read FCapacity Write FCapacity;
    property TimeOut: cardinal Read FTimeOut Write FTimeOut;
    property OnGetObject: TNotifyEvent Read FOnGetObject Write FOnGetObject;
    property OnException: TMessageException Read FOnException Write FOnException;
    property OnDataNeeded: TNotifyEvent Read FOnDataNeeded Write FOnDataNeeded;
    property OnReleaseObject: TNotifyEvent Read FOnReleaseObject Write FOnReleaseObject;
    property OnKillObject: TNotifyEvent Read FOnKillObject Write FOnKillObject;
    property OnCreateObject: TNotifyEvent read FOnCreateObject write FOnCreateObject;
    property OnLog: TPoolLog Read FOnLog Write FOnLog;
    property OwnObjects: boolean read FOwnObjects write FOwnObjects;
  end;
  {$M-}

Notice that there is a constraint in the generic, it can only be a class <T: class>, since the purpose is to store objects. The class can be used in a concurrent manner since it implements locking primitives.

Now the implementation:

{ TObjectPool<T> }

procedure TObjectPool<T>.Clear;
var
  i: integer;

begin
  inherited;

  FLock.Lock;
  try
    if FOwnObjects then
    begin
      for i := FFree.Count - 1 downto 0 do
        FFree[i].Free;
    end;
    FFree.Clear;

    if FOwnObjects then
    begin
      for i := FBusy.Count - 1 downto 0 do
        FBusy[i].Free;
    end;
    FBusy.Clear;
  finally
    FLock.UnLock;
  end;
end;

procedure TObjectPool<T>.ClearObject(aObject: T);
var
  I: IPoolable;

begin
  if aObject.GetInterface(IPoolable, I) then
    I.Clear;
end;

function TObjectPool<T>.Count: cardinal;
begin
  Result := FFree.Count + FBusy.Count;
end;

constructor TObjectPool<T>.Create;
begin
  inherited Create;

  FOnLog := nil;
  FOnDataNeeded := nil;
  FOnReleaseObject := nil;
  FOnGetObject := nil;
  FOnKillObject := nil;
  FOnCreateObject := nil;
  FCurrent := -1;
  FTimeOut := 3000;
  FUseGarbage := False;
  FGarbageSleep := 30000;
  FOnGarbage := nil;
  FOnException := nil;
  FOwnObjects := True;
  FCapacity := MaxLongint;
  FFree := TList<T>.Create;
  FBusy := TList<T>.Create;
  FLock := TCriticalLock.Create;
end;

destructor TObjectPool<T>.Destroy;
begin
  Clear;

  FFree.Free;
  FBusy.Free;
  FLock := nil;

  inherited Destroy;
end;

procedure TObjectPool<T>.DoDataNeeded(aObject: T);
begin
  if Assigned(FOnGetObject) then
    FOnGetObject(aObject);
end;

procedure TObjectPool<T>.DoRelease(aObject: T);
begin
  if Assigned(FOnReleaseObject) then
    FOnReleaseObject(aObject);
end;

function TObjectPool<T>.Used: integer;
begin
  Result := FBusy.Count;
end;

function TObjectPool<T>.GetFree(aIndex: integer): T;
begin
  result := FFree[aIndex];
end;

function TObjectPool<T>.GetItem(aIndex: integer): T;
begin
  Result := FBusy[aIndex];
end;

function TObjectPool<T>.Get: T;
var
  i: integer;

begin
  FLock.Lock;
  try
    i := FFree.Count - 1;
    if i >= 0 then
    begin  //At least there is one free object
      Result := GetFree(i);
      FBusy.Add(Result);
      FFree.Delete(i);
      ClearObject(result);
    end else
    begin
      CheckCapacity;

      result := CreateClass;
      FBusy.Add(result);
      SetPooled(result);
    end;

    DoDataNeeded(Result);
  finally
    FLock.UnLock;
  end;
end;

procedure TObjectPool<T>.Grow(aSize: cardinal);
var
  i: integer;
  l: TList<T>;

begin
  if Count + aSize > FCapacity then
    raise Exception.Create('Cannot grow more than capacity ' + IntToStr(FCapacity));

  FLock.Lock;
  try
    l := TList<T>.Create;
    try
      for i := 0 to aSize - 1 do
        l.Add(Get);
    finally
      for i := 0 to l.Count - 1 do
        Release(l[i]);
      l.Free;
    end;
  finally
    FLock.UnLock;
  end;
end;

procedure TObjectPool<T>.CheckCapacity;
begin
  if Count >= FCapacity then
    raise ETooManyObjects.Create('Maximum objects reached', []);
end;

procedure TObjectPool<T>.CheckNull(aObject: T);
begin
  if aObject = nil then
    raise Exception.Create('Nil object is not valid');
end;

procedure TObjectPool<T>.KillObject(aObject: T; aWaitGarbage: boolean = True);
var
  i: integer;

begin
  FLock.Lock;
  try
    CheckNull(aObject);
    { TODO : Wait for garbage }

    i := FBusy.IndexOf(aObject);
    if i > -1 then
      FBusy.Delete(i)
    else
    begin
      i := FFree.IndexOf(aObject);
      if i = -1 then
        raise Exception.Create('Object ' + aObject.ClassName + ' not in pool');
      FFree.Delete(i);
    end;

    if Assigned(FOnKillObject) then
      FOnKillObject(aObject);

    if FOwnObjects then
      aObject.Free;
  finally
    FLock.UnLock;
  end;
end;

procedure TObjectPool<T>.Release(aObject: T);
var
  item: T;

begin
  CheckNull(aObject);

  FLock.Lock;
  try
    item := FBusy.Extract(aObject);
    if item = nil then
      raise Exception.Create('Object ' + aObject.ClassName + ' not in pool');
    FFree.Add(item);

    DoRelease(aObject);
  finally
    FLock.UnLock;
  end;
end;

procedure TObjectPool<T>.ReleaseAll;
var
  i: integer;

begin
  FLock.Lock;
  try
    for i := FBusy.Count - 1 downto 0 do
      FFree.Add(FBusy[i]);
    FBusy.Clear;
  finally
    FLock.UnLock;
  end;
end;

function TObjectPool<T>.CreateClass: T;
begin
  Result := T.Create;

  if Assigned(FOnCreateObject) then
    FOnCreateObject(result);
end;

function TObjectPool<T>.NonUsed: integer;
begin
  Result := FFree.Count;
end;

procedure TObjectPool<T>.SetPooled(aObject: T);
var
  I: IPoolable;

begin
  if aObject.GetInterface(IPoolable, I) then
    I.SetPooled(True);
end;

The use is quite easy:

var
  pool: TObjectPool<TObject>;
  i: integer;
  obj: TObject;

begin
  pool := TObjectPool<TObject>.Create;
  //Although this loop counts 1000000 elements, only one object is created
  for i := 0 to 999999 do
  begin
    obj := pool.Get;  //Every Get() must have its own Release()
    pool.Release;
  end;
end;
A proper use can be located in the 3d engine, the polygon system is cached this way.