unit BambooThread.PoolLite;
interface
uses
System.SysUtils;
type
TInterface_BambooThreadPoolLite = interface
function Runing: Boolean;
procedure ClearProc;
procedure ThreadStart(aProc: TProc);
end;
function Create_BambooThreadPool(aMaxThreadCount: Byte): TInterface_BambooThreadPoolLite;
implementation
uses
System.Classes,
System.Generics.Collections;
type
TBambooThreadPoolLite = class;
TCacheThread = class(TThread)
private
FThreadPool: TBambooThreadPoolLite;
FProc: TProc;
protected
procedure Execute; override;
procedure Do_Resume;
public
constructor Create(aThreadPool: TBambooThreadPoolLite);
end;
TBambooThreadPoolLite = class(TInterfacedObject, TInterface_BambooThreadPoolLite)
private type
TItem_Proc = record
FProc: TProc;
end;
private
FLock: TObject;
FQueue_Thread: TQueue<TCacheThread>;
FQueue_Proc: TQueue<TItem_Proc>;
FUsedCount: Integer;
FMaxThreadCount: Byte;
FCreateCount: Integer;
private
function TryDequeueProc(var aProc: TProc): Boolean;
function TryDequeueThread(var aThread: TCacheThread): Boolean;
procedure Do_Proc_Queue;
function Internal_Get_Thread: TCacheThread;
function Internal_Do_Start_Queue(aForceThread: Boolean): Boolean;
private
function Runing: Boolean;
procedure ClearProc;
procedure ThreadStart(aProc: TProc);
public
constructor Create(aMaxThreadCount: Byte);
destructor Destroy; override;
end;
function Create_BambooThreadPool(aMaxThreadCount: Byte): TInterface_BambooThreadPoolLite;
begin
Result := TBambooThreadPoolLite.Create(aMaxThreadCount);
end;
{ TCacheThread }
constructor TCacheThread.Create(aThreadPool: TBambooThreadPoolLite);
begin
inherited Create(True);
FThreadPool := aThreadPool;
FreeOnTerminate := False;
end;
procedure TCacheThread.Do_Resume;
begin
while Suspended do
Suspended := False;
end;
procedure TCacheThread.Execute;
begin
while not Terminated do
begin
try
if Assigned(FProc) then
FProc;
except
end;
FProc := nil;
with FThreadPool do
begin
TMonitor.Enter(FLock);
Internal_Do_Start_Queue(True);
FQueue_Thread.Enqueue(Self);
Dec(FUsedCount);
TMonitor.Exit(FLock);
end;
Suspended := True;
end;
end;
{ TBambooThreadPoolLite }
procedure TBambooThreadPoolLite.ClearProc;
begin
TMonitor.Enter(FLock);
FQueue_Proc.Clear;
TMonitor.Exit(FLock);
end;
constructor TBambooThreadPoolLite.Create(aMaxThreadCount: Byte);
begin
inherited Create;
FMaxThreadCount := aMaxThreadCount;
FLock := TObject.Create;
FQueue_Thread := TQueue<TCacheThread>.Create;
FQueue_Proc := TQueue<TItem_Proc>.Create;
FMaxThreadCount := aMaxThreadCount;
if FMaxThreadCount = 0 then
FMaxThreadCount := 1;
end;
destructor TBambooThreadPoolLite.Destroy;
var
aThread: TCacheThread;
begin
while Runing do
Sleep(10);
TMonitor.Enter(FLock);
try
while TryDequeueThread(aThread) do
begin
while not aThread.Suspended do
Sleep(0);
aThread.Terminate;
aThread.Do_Resume;
aThread.WaitFor;
aThread.Free;
end;
FQueue_Thread.Free;
FQueue_Proc.Free;
inherited Destroy;
finally
TMonitor.Exit(FLock);
FLock.Free;
end;
end;
procedure TBambooThreadPoolLite.Do_Proc_Queue;
var
aHaveNew: Boolean;
aProc: TProc;
begin
repeat
TMonitor.Enter(FLock);
aHaveNew := TryDequeueProc(aProc);
TMonitor.Exit(FLock);
if aHaveNew then
try
aProc;
except
end;
until not aHaveNew;
end;
function TBambooThreadPoolLite.Internal_Do_Start_Queue(aForceThread: Boolean): Boolean;
var
aThread: TCacheThread;
begin
Result := (FQueue_Proc.Count > 0) and (aForceThread or (FUsedCount < FMaxThreadCount));
if Result then
begin
Inc(FUsedCount);
aThread := Internal_Get_Thread;
aThread.FProc := Do_Proc_Queue;
aThread.Do_Resume;
end;
end;
function TBambooThreadPoolLite.Internal_Get_Thread: TCacheThread;
begin
if not TryDequeueThread(Result) then
begin
Result := TCacheThread.Create(Self);
Inc(FCreateCount);
end;
while not Result.Suspended do
Sleep(0);
end;
function TBambooThreadPoolLite.Runing: Boolean;
begin
TMonitor.Enter(FLock);
Result := FCreateCount > FQueue_Thread.Count;
TMonitor.Exit(FLock);
end;
procedure TBambooThreadPoolLite.ThreadStart(aProc: TProc);
var
aItem_Proc: TItem_Proc;
begin
if not Assigned(aProc) then
Exit;
TMonitor.Enter(FLock);
aItem_Proc.FProc := aProc;
FQueue_Proc.Enqueue(aItem_Proc);
Internal_Do_Start_Queue(False);
TMonitor.Exit(FLock);
end;
function TBambooThreadPoolLite.TryDequeueProc(var aProc: TProc): Boolean;
var
aItem_Proc: TItem_Proc;
begin
Result := FQueue_Proc.Count > 0;
if Result then
begin
aItem_Proc := FQueue_Proc.Dequeue;
aProc := aItem_Proc.FProc;
end;
end;
function TBambooThreadPoolLite.TryDequeueThread(var aThread: TCacheThread): Boolean;
begin
Result := FQueue_Thread.Count > 0;
if Result then
aThread := FQueue_Thread.Dequeue;
end;
end.

下面是一个功能扩展的示例：
unit BambooThread.Helper;
interface
uses
BambooThread.Defaults,
System.SysUtils;
type
TBambooHelper_ThreadPool = record
class procedure ThreadStart<T>(aThreadPool: TInterface_BambooThreadPool; const aID: T; aProc: TProc<T>); static;
end;
implementation
{ TBambooHelper_ThreadPool }
class procedure TBambooHelper_ThreadPool.ThreadStart<T>(aThreadPool: TInterface_BambooThreadPool; const aID: T; aProc: TProc<T>);
begin
if Assigned(aThreadPool) and Assigned(aProc) then
aThreadPool.ThreadStart(
procedure
begin
aProc(aID);
end);
end;
end.

火钳刘明

要发就发完整代码，要不就对自己的代码功能加个简要说明，不然这帖毫无意义！

今天刚才百度首页看了个桥布斯跟莫大师的事，不愧是桥布斯，激进的人也有细致的一面。
不象某些人发个不带注释不知所云的帖子，自己开个号来吹，似乎别人都必须要看懂理解他所写的东西似的。
好好跟万一老师学学吧，学学人家是怎么表达的，不是每个人都有工夫跟这不白痴的大师去讲什么东西的。

好高级，我都没用过这种……

自以为很厉害听不进去别人意见不会好好说话

先顶后看，学习下

笑死 还是吧主 先不管别人说的对不对 张口闭口就喷人 太喜感了

大家都是老家伙了，何必掐起来，各省一句就好

围观中..

这是战贴吗？哈哈。
你这个线程池还少了一点东西啊，就是对假死线程的处理，不然多任务处理时，很容易卡死整个应用。。。

可以解说下意思吗

不错

没注释 看不懂 另外楼主这么清高 发出来干什么都不懂 这里基本都是小白

Delphi XE7开始，已经有System.Threading单元，RTL有线程池了

线程池用qworker吧