delphi线程池

// 单元功用: 线程池
// 单元设计: 陈新光
// 设计日期: 2012-09-03
 
unit ThreadPool;
 
interface
 
uses
  system.Classes, system.SyncObjs, system.SysUtils,
  system.DateUtils, GlobalVar, Vcl.Forms, Winapi.Windows;
 
type
  TWorkThread = class(TThread)
  private
    FThreadMethod: TThreadMethod;
    Fsync: Boolean;
    FEvent: THandle;
  protected
    procedure Execute; override;
  public
    constructor Create; overload;
    destructor Destroy; override;
    property Sync: Boolean read Fsync write Fsync;
    property ThreadMethod: TThreadMethod read FThreadMethod write FThreadMethod;
    procedure Run;
  end;
 
  PServerObject = ^TServerObject;
 
  TServerObject = record
    ServerObject: TWorkThread;
    InUse: Boolean;
  end;
 
  TThreadPool = class
  private
    FCriticalSection: TCriticalSection;
    FServerObjects: TList;
    FPoolSize: integer;
 
  public
    constructor Create; overload;
    destructor Destroy; override;
    function Lock: TWorkThread;
    procedure Unlock(Value: TWorkThread);
    procedure Init;
    property PoolSize: integer read FPoolSize write FPoolSize;
  end;
 
var
  G_ThreadPool: TThreadPool;
 
implementation
 
uses CommonFunction;
 
constructor TThreadPool.Create;
begin
  FPoolSize := G_ThreadPoolSize;
  FServerObjects := TList.Create;
  FCriticalSection := TCriticalSection.Create;
end;
 
destructor TThreadPool.Destroy;
begin
  while FServerObjects.Count > 0 do
  begin
    Dispose(PServerObject(FServerObjects[0]));
    FServerObjects.Delete(0);
  end;
  FreeAndNil(FServerObjects);
  FreeAndNil(FCriticalSection);
  inherited Destroy;
end;
 
procedure TThreadPool.Init;
var
  i: integer;
  p: PServerObject;
begin
  if not Assigned(FServerObjects) then
    exit;
  for i := 1 to FPoolSize do
  begin
    New(p);
    if Assigned(p) then
    begin
      p^.ServerObject := TWorkThread.Create;
      p^.InUse := False;
      FServerObjects.Add(p);
    end;
  end;
end;
 
function TThreadPool.Lock: TWorkThread;
var
  i: integer;
begin
  Result := nil;
  try
    FCriticalSection.Enter;
    try
      for i := 0 to FServerObjects.Count - 1 do
      begin
        if (not PServerObject(FServerObjects[i])^.InUse) then
        begin
          PServerObject(FServerObjects[i])^.InUse := True;
          Result := PServerObject(FServerObjects[i])^.ServerObject;
          Break;
        end;
      end;
    finally
      FCriticalSection.Leave;
    end;
  except
    on E: Exception do
    begin
      LogInfo('TThreadPool.Lock' + E.Message);
      exit;
    end;
  end;
end;
 
procedure TThreadPool.Unlock(Value: TWorkThread);
var
  i: integer;
begin
  if not Assigned(Value) then
    exit;
  try
    FCriticalSection.Enter;
    try
      for i := 0 to FServerObjects.Count - 1 do
      begin
        if Value = PServerObject(FServerObjects[i])^.ServerObject then
        begin
          PServerObject(FServerObjects[i])^.InUse := False;
         // Value.Suspended := True;
          Value.ThreadMethod := nil;
          Break;
        end;
      end;
    finally
      FCriticalSection.Leave;
    end;
  except
    on E: Exception do
    begin
      LogInfo('TThreadPool.Unlock' + E.Message);
      exit;
    end;
  end;
end;
 
{ TWorkThread }
 
constructor TWorkThread.Create;
begin
  FEvent := CreateEvent(nil, True, False, nil);
  Create(True);
  FreeOnTerminate := True;
end;
 
destructor TWorkThread.Destroy;
begin
  CloseHandle(FEvent);
  inherited;
end;
 
procedure TWorkThread.Execute;
begin
  inherited;
  while not Terminated do
    if WaitForSingleObject(FEvent, INFINITE) = WAIT_OBJECT_0 then
      if Assigned(FThreadMethod) then
        if Fsync then
          Synchronize(FThreadMethod)
        else
          FThreadMethod;
end;
 
procedure TWorkThread.Run;
begin
  PulseEvent(FEvent);
end;
 
end.