Is there a generic "Object Pool" implementation for Delphi?

Question

I came across this while looking for a database connection pool implementation for Delphi.

An object pool needs two methods:

• get - to acquire an object from the pool (this will create a new instance if the pool is empty or its size has not reached its maximum size), this methods must be thread safe so that one object can not be acquired by two threads at the same time. If all objects are iin use, the get method must block (maybe with an optional time out)

• put - to release (return) an object to the pool

So a use case would look like

O := Pool.Get;
try
  ... use O
finally
  Pool.Put(O);
end;

Update: added Delphi 2009 tag so Generics.Collections and TMonitor could be part of the implementation

Answer 1

TMonitor is badly broken in Delphi-2009. It became functional in Delphi-XE2 upd 4, which the answer here is based on (or newer).

Here, the object pool is based on a thread-safe TThreadedQueue.

A mechanism for creating pooled objects is built in with thread safety. Getting an object from the pool is thread-safe and a timeout is defined at pool creation. The queue size is also defined at pool creation, where a callback routine for object creation also is passed.

uses
  System.Classes,Generics.Collections,System.SyncObjs,System.Diagnostics;

type
  TObjectConstructor = function : TObject;

  TMyPool = Class
  private
    FQueueSize,FAllocatedObjects : integer;
    FGetTimeOut : Integer;
    FQueue : TThreadedQueue<TObject>;
    FObjectConstructor : TObjectConstructor;
    FCS : TCriticalSection;
    function AllocateNewObject : TObject;
  public
    Constructor Create( AnObjectConstructor : TObjectConstructor;
                        QueueSize           : Integer;
                        GetTimeOut          : Integer);
    Destructor Destroy; override;
    procedure Put( const AnObject : TObject);
    function Get( var AnObject : TObject) : TWaitResult;
  End;

function TMyPool.AllocateNewObject: TObject;
begin
  FCS.Enter;
  Try
    if Assigned(FObjectConstructor) and
       (FAllocatedObjects < FQueueSize)
    then
    begin
      Inc(FAllocatedObjects);
      Result := FObjectConstructor;
    end
    else
      Result := Nil;
  Finally
    FCS.Leave;
  End;
end;

constructor TMyPool.Create( AnObjectConstructor : TObjectConstructor;
                            QueueSize           : Integer;
                            GetTimeOut          : Integer);
begin
  Inherited Create;

  FCS := TCriticalSection.Create;
  FAllocatedObjects := 0;
  FQueueSize := QueueSize;
  FObjectConstructor := AnObjectConstructor;
  FGetTimeOut := GetTimeOut;
  FQueue := TThreadedQueue<TObject>.Create(FQueueSize+1,Infinite,10);
  // Adding an extra position in queue to safely remove all items on destroy
end;

destructor TMyPool.Destroy;
var
  AQueueSize : integer;
  AnObject : TObject;
  wr : TWaitResult;
begin
  FQueue.PushItem(Nil); // Just to make sure we have an item in queue
  repeat // Free objects in queue
    AnObject := nil;
    wr := FQueue.PopItem(AQueueSize,AnObject);
    if (wr = wrSignaled) then
      AnObject.Free;
  until (AQueueSize = 0);
  FQueue.Free;
  FCS.Free;

  Inherited;
end;

function TMyPool.Get(var AnObject: TObject) : TWaitResult;
var
  sw : TStopWatch;
begin
  AnObject := nil;
  // If queue is empty, and not filled with enough objects, create a new.
  sw := TStopWatch.Create;
  repeat
    sw.Start;
    Result := FQueue.PopItem( AnObject); // Timeout = 10 ms
    if (Result = wrTimeOut) and
       (FAllocatedObjects < FQueueSize) and
       Assigned(FObjectConstructor)
    then begin  // See if a new object can be allocated
      AnObject := Self.AllocateNewObject;
      if Assigned(AnObject) then
      begin
        Result := wrSignaled;
        Exit;
      end;
    end;
    sw.Stop;
  until (Result = wrSignaled) or (sw.ElapsedMilliseconds > FGetTimeOut);
end;

procedure TMyPool.Put( const AnObject: TObject);
begin
  FQueue.PushItem(AnObject); // Put object back into queue
end;

Define your TObjectConstructor function like this:

function MyObjectConstructor : TObject;
begin
  Result := TMyObject.Create( {Some optional parameters});
end;

And an example how to use:

var
  AnObject : TObject;
  MyObject : TMyObject;
  wr : TWaitResult;
begin
  wr := MyObjPool.Get(AnObject);
  if (wr = wrSignaled) then 
  begin
    MyObject := TMyObject(AnObject);
    try
      // Do something with MyObject
    finally
      MyObjPool.Put(AnObject);
    end;
  end;
end