6

我正在创建一个控制台应用程序，它需要运行多个线程才能完成任务。我的问题是线程一个接一个地运行（线程1开始->工作->结束，然后才启动线程2），而不是同时运行。另外我不希望超过 10 个线程同时工作（性能问题）。Bellow 是控制台应用程序和使用的数据模块的示例代码。我的应用程序以相同的方式工作。我使用了数据模块，因为在线程完成后，我必须用这些信息填充数据库。代码中也有注释解释这是做某事的原因。

应用程序控制台代码：

    program Project2;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Unit1 in 'Unit1.pas' {DataModule1: TDataModule};

var dm:TDataModule1;
begin
   dm:=TDataModule1.Create(nil);
   try
     dm.execute;
   finally
    FreeAndNil(dm);
   end;
end.

和数据模块代码

    unit Unit1;

interface

uses
  SysUtils, Classes, SyncObjs, Windows, Forms;

var   FCritical: TRTLCriticalSection;//accessing the global variables  

type
  TTestThread = class(TThread)
  protected
    procedure Execute;override;
  end;
  TDataModule1 = class(TDataModule)
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
  private
    { Déclarations privées }
  public

    procedure execute;
    procedure CreateThread();
    procedure Onterminatethrd(Sender: TObject);
  end;

var
  DataModule1       : TDataModule1;
  FthreadCount      : Integer;  //know how many threads are running


implementation

{$R *.dfm}

{ TTestThread }

procedure TTestThread.Execute;
var
  f                 : TextFile;
  i                 : integer;
begin
  EnterCriticalSection(fcritical);
  AssignFile(f, 'd:\a' + inttostr(FthreadCount) + '.txt');
  LeaveCriticalSection(fcritical);
  Rewrite(f);
  try
    i := 0;
    while i <= 1000000 do // do some work...
      Inc(i);
    Writeln(f, 'done');
  finally
    CloseFile(f);
  end;
end;

{ TDataModule1 }

procedure TDataModule1.CreateThread;
var
  aThrd             : TTestThread;
begin
  aThrd := TTestThread.Create(True);
  aThrd.FreeOnTerminate := True;
  EnterCriticalSection(fcritical);
  Inc(FthreadCount);
  LeaveCriticalSection(fcritical);
  aThrd.OnTerminate:=Onterminatethrd;
  try
    aThrd.Resume;
  except
    FreeAndNil(aThrd);
  end;
end;

procedure TDataModule1.Onterminatethrd(Sender: TObject);
begin
  EnterCriticalSection(fcritical);
  Dec(FthreadCount);
  LeaveCriticalSection(fcritical);
end;

procedure TDataModule1.DataModuleCreate(Sender: TObject);
begin
  InitializeCriticalSection(fcritical);
end;

procedure TDataModule1.DataModuleDestroy(Sender: TObject);
begin
  DeleteCriticalSection(fcritical);
end;

procedure TDataModule1.execute;
var
  i                 : integer;
begin
  i := 0;
  while i < 1000 do
  begin
    while (FthreadCount = 10) do
      Application.ProcessMessages;//wait for an thread to finish. max threads at a //time =10

    CreateThread;

    EnterCriticalSection(fcritical);
    Inc(i);
    LeaveCriticalSection(fcritical);

    while FthreadCount > 0 do //wait for all threads to finish in order to close the //main thread
    begin
      Application.ProcessMessages;
      CheckSynchronize;
    end;
  end;
end;

end.

所以，正如我所说的，问题是我的线程一个接一个地运行，而不是同时工作。我也看到有时只有第一个线程工作，之后所有其他线程都创建并完成。在我的应用程序中，所有代码都受 try-excepts 保护，但不会引发错误。

有人可以给我一个建议吗？

4

3 回答 3

7

至少你应该把

while FthreadCount > 0 do //wait for all threads to finish in order to close the //main thread
begin
  Application.ProcessMessages;
  CheckSynchronize;
end;

在主循环之外。这个等待循环是导致阻塞的原因。对于主循环的每个整数 i，它都会等待 FThreadCount 降至零。

旁注：通常您不需要使用关键部分保护局部变量。尽管其中有进程消息可能会搞砸，因为它可能会导致重新进入。

于 2010-06-27T08:10:52.563 回答
1

我遵循了 Marjan 的建议，以下代码似乎工作正常。我正在回答我自己的问题，以便提供一个响应代码，其他人可以对其进行分析，并在需要时进行更正。

unit Unit1;

interface

uses
  SysUtils, Classes, SyncObjs, Windows, Forms, Dialogs;

var   FCritical: TRTLCriticalSection;  

type
  TTestThread = class(TThread)
  protected
    procedure Execute;override;
  end;
  TDataModule1 = class(TDataModule)
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
  private
    { Déclarations privées }
  public

    procedure execute;
    procedure CreateThread();
    procedure Onterminatethrd(Sender: TObject);
  end;

var
  DataModule1       : TDataModule1;
  FthreadCount      : Integer;


implementation

{$R *.dfm}

{ TTestThread }

procedure TTestThread.Execute;
var
  f                 : TextFile;
  i                 : integer;

begin
 AssignFile(f, 'd:\a\a' + inttostr(FthreadCount) + '.txt');
 if fileexists('d:\a\a' + inttostr(FthreadCount) + '.txt') then
  Append(f)
 else
  Rewrite(f);
   try
    i := 0;
    while i <= 1000000 do
      Inc(i);
  Writeln(f, 'done '+floattostr(self.Handle));
  finally
    CloseFile(f);
  end;
end;

{ TDataModule1 }

procedure TDataModule1.CreateThread;
var
  aThrd             : TTestThread;
begin
  aThrd := TTestThread.Create(True);
  aThrd.FreeOnTerminate := True;
  EnterCriticalSection(fcritical);
  Inc(FthreadCount);
  LeaveCriticalSection(fcritical);
  aThrd.OnTerminate:=Onterminatethrd;
  try
    aThrd.Resume;
  except
    FreeAndNil(aThrd);
  end;
end;

procedure TDataModule1.Onterminatethrd(Sender: TObject);
begin
  EnterCriticalSection(fcritical);
    Dec(FthreadCount);
  LeaveCriticalSection(fcritical);
end;

procedure TDataModule1.DataModuleCreate(Sender: TObject);
begin
  InitializeCriticalSection(fcritical);
end;

procedure TDataModule1.DataModuleDestroy(Sender: TObject);
begin
  DeleteCriticalSection(fcritical);
end;

procedure TDataModule1.execute;
var
  i                 : integer;
begin
  i := 0;
 try
  while i < 1000 do
  begin
    while (FthreadCount = 10) do
     begin
      Application.ProcessMessages;
      CheckSynchronize
     end;
    CreateThread;
    Inc(i);
  end;
    while FthreadCount > 0 do
    begin
      Application.ProcessMessages;
      CheckSynchronize;
    end;
 except on e:Exception do
//
 end;
end;

end.

此刻我已经多次测试了这段代码，它似乎工作正常。如果 Rob 会用一个小例子回答我如何在这个问题上实现信号量，我也会在这里发布整个代码。

于 2010-06-28T11:00:25.110 回答
-1

我有一个单元可以完全满足您的需求。只需从以下位置下载：

Cromis.Threading

在里面你有两个类：

  1. TTaskPool：任务池。异步做事的简单方法。
  2. TTaskQueue：异步任务队列。像标准的 FIFO 队列一样工作。

例如，TTaskQueue 可以与普通的 vanila 线程一起独立使用。它在单个线程内阻塞并将请求排队。

如果这还不够，您可以在以下位置查看 OmniThreadLibrary：

全线程库

这是一个强大的线程库，远远优于我所拥有的。但使用起来也更复杂（但与经典线程相比仍然非常容易）。

于 2010-06-27T10:35:29.410 回答