Delphi 高效的通用对象池

       对象池的设计,可以让一定频繁使用到的对象可以重用, 无需不断进行create/destroy,极大加快了运行效率．

　　下面是一个非常简单的利用队列设计而成线程安全的通用对象池.

unit uObjPoolUnit;

interface

{
  通用的对象池
  create by rocklee, 9/Jun/2017
  QQ:1927368378
  应用例子：
  FPool := TObjPool.Create(10);  //定义一个最大可以容纳10个对象的缓冲对象池
  FPool.OnNewObjectEvent := onNewObject; //定义新建对象的事件
  FPool.setUIThreadID(tthread.CurrentThread.ThreadID); //设置主线程的ThreadID
  FPool.WaitQueueSize := 100; //排队等待的最大上限
  FPool.OnStatusEvent:=onStatus; //status输出
  ...
  var lvObj:Tobject;
  lvObj := FPool.getObject(); //从池中获得对象
  ...
  FPool.returnObject(lvObj); //归还对象

}
uses
  classes, System.Contnrs, forms, sysutils,SyncObjs;

type
  TOnNewObjectEvent = function(): Tobject of object;
  TOnStatusEvent = procedure(const pvStatus: String) of object;

  TObjPool = class(TQueue)
  private
    /// 

    /// 缓冲池大小
    /// 
    fCapacity: Cardinal;
    fSize: Cardinal;
    fUIThreadID: THandle;
    fOnNewObjectEvent: TOnNewObjectEvent;
    fWaitCounter: integer;
    fWaitQueueSize: integer;
    fOnStatusEvent: TOnStatusEvent;
    fLockObj: integer;
    fLock:TCriticalSection;
    function innerPopItem(): Tobject;
    procedure doStatus(const pvStatus: STring);
  public
    procedure Lock;
    procedure UnLock;
    /// 

    /// 当池空时等待的队列最大数，若超过等待最大数时会直接返回失败
    /// 
    property WaitQueueSize: integer read fWaitQueueSize write fWaitQueueSize;
    /// 

    /// 从对象池中获得对象，如果池为空时，会调用OnNewObjectEvent新建对象，
    ///
    /// 
    function getObject(pvCurThreadID: THandle = 0): Tobject; virtual;
    /// 

    /// 归还对象
    /// 
    procedure returnObject(pvObject: Tobject); virtual;
    /// 

    /// 当前池内与借出的对象总共多少
    /// 
    property MntSize: Cardinal read fSize;
    /// 

    /// 当前等待队列需求量
    /// 
    property CurWaitCounter: integer read fWaitCounter;
    /// 

    /// 获得当前池里对象多少
    /// 
    function getPoolSize: integer;
    property OnStatusEvent: TOnStatusEvent read fOnStatusEvent write fOnStatusEvent;
    procedure Clear;
    procedure setUIThreadID(pvThreadID: THandle);
    constructor Create(pvCapacity: Cardinal);
    destructor destroy; override;
    property OnNewObjectEvent: TOnNewObjectEvent read fOnNewObjectEvent
      write fOnNewObjectEvent;

  end;

implementation

procedure SpinLock(var Target: integer);
begin
  while AtomicCmpExchange(Target, 1, 0) <> 0 do
  begin
{$IFDEF SPINLOCK_SLEEP}
    Sleep(1); // 1 对比0 (线程越多，速度越平均)
{$ENDIF}
  end;
end;

procedure SpinUnLock(var Target: integer);
begin
  if AtomicCmpExchange(Target, 0, 1) <> 1 then
  begin
    Assert(False, 'SpinUnLock::AtomicCmpExchange(Target, 0, 1) <> 1');
  end;
end;

{ TObjPool }

procedure TObjPool.Clear;
var
  lvObj: Pointer;
  lvCC:integer;
begin
  // 检查借出去的是否全都归还
  doStatus(Format('管理对象数:%d,池中对象数%d',[self.MntSize,count]));
  Assert(self.Count = fSize, format('还有%d个对象借出而没归还', [MntSize - self.Count]));
  lvCC:=0;
  repeat
    lvObj := innerPopItem();
    if lvObj<>nil then begin
        TObject(lvObj).Destroy;
        INC(lvCC);
    end;
  until lvObj=nil;
  fSize:=0;
  doStatus(format('销毁%d对象',[lvCC]));
  inherited;
end;

constructor TObjPool.Create(pvCapacity: Cardinal);
begin
  inherited Create;
  fLock:=TCriticalSection.Create;
  fSize := 0;
  fWaitCounter := 0;
  fCapacity := pvCapacity;
  fUIThreadID := 0;
  fLockObj := 0;
  fOnNewObjectEvent := nil;
  fOnStatusEvent := nil;
end;

destructor TObjPool.destroy;
begin
  Clear;
  fLock.Destroy;
  inherited;
end;

procedure TObjPool.doStatus(const pvStatus: STring);
begin
  if (@fOnStatusEvent = nil) then
    exit;
  fOnStatusEvent(pvStatus);
end;

function TObjPool.getObject(pvCurThreadID: THandle = 0): Tobject;
var
  lvCurTheadID: THandle;
begin
  Assert(@fOnNewObjectEvent <> nil, 'OnNewObectEvent is not assigned!');
  result := innerPopItem();
  if result <> nil then
  begin
    exit;
  end;
  if fWaitCounter > fWaitQueueSize then
  begin // 前面排队数量超过指定上限则退出
    doStatus('前面排队数量超过指定上限，退出...');
    exit;
  end;

  if fSize = fCapacity then
  begin // 已经达到上限，等待
    // sfLogger.logMessage('排队等候...');
    doStatus('排队等候...');
    // InterlockedIncrement(fWaitCounter);
    AtomicIncrement(fWaitCounter);
    if pvCurThreadID <> 0 then
      lvCurTheadID := pvCurThreadID
    else
      lvCurTheadID := TThread.CurrentThread.ThreadID;
    while (result = nil) do
    begin
      if (lvCurTheadID = fUIThreadID) then
      begin
        Application.ProcessMessages;
      end;
      Sleep(1);
      result := innerPopItem();
    end;
    AtomicDecrement(fWaitCounter);
    exit;
  end;
  Lock;
  try
    result := fOnNewObjectEvent();
  finally
    UnLock;
  end;
  AtomicIncrement(fSize);
end;

function TObjPool.getPoolSize: integer;
begin
  result := Count;
end;

function TObjPool.innerPopItem: Tobject;
begin
  Lock;
  try
    if Count=0 then begin
       result:=nil;
       exit;
    end;
    result := Tobject(self.PopItem());
  finally
    UnLock;
  end;
end;

procedure TObjPool.Lock;
begin
  SpinLock(fLockObj);
  //fLock.Enter;
end;
procedure TObjPool.UnLock;
begin
  SpinUnLock(fLockObj);
  //fLock.Leave;
end;

procedure TObjPool.returnObject(pvObject: Tobject);
begin
  Lock;
  try
    self.PushItem(pvObject);
  finally
    UnLock;
  end;
end;

procedure TObjPool.setUIThreadID(pvThreadID: THandle);
begin
  fUIThreadID := pvThreadID;
end;


end.

Git 地址:  https://github.com/tiger822/Delphi_Repository/tree/master/object%20pool