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