multithreading - 虚拟Listview，线程和内存消耗不下降

Question

*更新:有两个人告诉我，如果没有真实/完整的代码，很难帮助我。下面几乎都有它，但以防万一我忘记了什么，就在这里! laserrental.ca/MemoryProblem.zip

<小时/>

使用的 Delphi 版本:2007

你好，

我是线程和虚拟 ListView 的新手，所以我的问题可能很容易解决；然而，我已经被困了几天了。基本上，这就是我所拥有的:

http://image.noelshack.com/fichiers/2012/32/1344440638-urlsloader.png

用户点击加载 URL，URL 将存储在以下记录中:

type TVirtualList=record
  Item:Integer; // Index
  SubItem1:String; // Status
  SubItem2:String; // URL
end;

...

var
 LURLs : Array of TVirtualList;

该记录用于填充虚拟 ListView 。这是 OnData 代码:

procedure TForm1.ListViewData(Sender: TObject; Item: TListItem);
begin
 Item.Caption := IntToStr(LURLs[Item.Index].Item);
 Item.SubItems.Add(LURLs[Item.Index].SubItem1);
 Item.SubItems.Add(LURLs[Item.Index].SubItem2);
end;

当用户点击GO时，应用程序将启动一个线程来控制工作线程的创建。每个工作线程获取一个 URL，下载它并解析它以获取更多信息。

现在，我的问题是:内存消耗总是越来越高——至少根据任务管理器是这样的。如果我最小化应用程序并再次打开它，内存消耗会恢复正常......但虚拟内存消耗仍然非常高。现在，我知道很多人说任务管理器不可靠。然而，一段时间后，内存消耗变得如此之高，以至于无法再下载 URL。我收到 EOutOfMemory 错误。我的电脑变得 super 慢。

根据FastMM4，没有内存泄漏。

有趣的是:如果我清除 TVirtualList 记录，内存消耗(“正常”内存消耗和虚拟内存消耗)都会恢复正常。但除非我这样做，否则它就会保持超高。显然，这是一个问题，因为我希望应用程序能够下载成千上万个 URL；但有了这个错误，我不能走得太远。

清除TVirtualList记录的代码

ListView.Items.BeginUpdate;
SetLength(LURLs,0);
ListView.Items.Count := Length(LURLs);
ListView.Clear;
ListView.Items.EndUpdate;

<小时/>

所以我将应用程序精简到最核心的部分。该应用程序不进行解析，而是使用关键部分加载单个本地 HMTL 文件，而不是下载文件。内存消耗问题依然存在。

<小时/>

控制线程:

unit Loader;

interface

uses Classes, SysUtils, Windows, Thread, Forms;

type
  TLoader = class(TThread)
  private
    { Private declarations }
  protected
    procedure Execute; override;
    procedure UpdateButtons;
    procedure UpdateListView;
  public
    constructor Create;
  end;

implementation

uses Main;

constructor TLoader.Create;
begin
 inherited Create(False);
 FreeOnTerminate := True;
end;

procedure TLoader.UpdateButtons;
begin
 Form1.BSwitch(false); // Re-enable interface
end;

procedure TLoader.UpdateListView;
begin
 Form1.ListView.Items.Item[BarP].MakeVisible(false); // Scroll down the listview
 Application.ProcessMessages;
end;

procedure TLoader.Execute;
begin
 while (BarP < Length(LURLs)) and (not(Terminated)) do  // Is there any URL left?
 begin
  if (ThreadsR < StrToInt(Form1.Threads.Text)) then // Have we met the threads limit?
  begin
   Synchronize(UpdateListView);
   TThreadWorker.Create(LURLs[BarP].SubItem1, BarP);
   InterlockedIncrement(ThreadsR);
   Inc(BarP);
  end else Sleep(100);
 end;

 while (not(ThreadsR = 0)) do Sleep(100);

 Synchronize(UpdateButtons);
end;

end.

工作线程:

unit Thread;

interface

uses Classes, SysUtils, Windows, Forms;

type
  TThreadWorker = class(TThread)
  private
    { Private declarations }
    Position : Integer;
    HtmlSourceCode : TStringList;
    StatusMessage, TURL : String;
    procedure UpdateStatus;
    procedure EndThread;
    procedure AssignVariables;
    procedure DownloadURL;
  protected
    procedure Execute; override;
  public
    constructor Create(URL : String ; LNumber : Integer);
  end;

implementation

uses Main;

var CriticalSection: TRTLCriticalSection;

constructor TThreadWorker.Create(URL : String ; LNumber : Integer);
begin
 inherited Create(False);
 TURL := URL;
 Position := LNumber;
 FreeOnTerminate := True;
end;

procedure TThreadWorker.UpdateStatus;
begin
 LURLs[Position].SubItem1 := StatusMessage;
 Form1.ListView.UpdateItems(Position,Position);
end;

procedure TThreadWorker.EndThread;
begin
 StatusMessage := 'Success';
 Synchronize(UpdateStatus);
 InterlockedIncrement(NDone);

 // I free Synapse THTTPSend variable.

 HtmlSourceCode.Free;
 InterlockedDecrement(ThreadsR);
end;

procedure TThreadWorker.AssignVariables;
begin
 StatusMessage := 'Working...';
 Synchronize(UpdateStatus);

 // I initialize Synapse THTTPsend variable.

 HtmlSourceCode := TStringList.Create;
end;

procedure TThreadWorker.DownloadURL;
begin
 (* This is where I download the URL with Synapse. The result file is then loaded
 with HtmlSourceCode for further parsing. *)

 EnterCriticalSection(CriticalSection);
  HtmlSourceCode.LoadFromFile(ExtractFilePath(application.exename)+'testfile.html');
 LeaveCriticalSection(CriticalSection);

 Randomize;
 Sleep(1000+Random(1500)); // Only for simulation
end;

procedure TThreadWorker.Execute;
begin
 AssignVariables;
 DownloadURL;
 EndThread;
end;

initialization
  InitializeCriticalSection(CriticalSection);

finalization
  DeleteCriticalSection(CriticalSection);

end.

Answer 1

您所描述的听起来像是内存泄漏或内存碎片。无论哪种方式，都很难判断，因为您没有显示如何分配和填充 URL 数组本身。

我建议完全摆脱TLoader并使用节流队列。下载网址时，检查是否已存在空闲的 TWorker，如果存在则让它下载该网址，否则如果尚未达到限制，则启动一个新的 TWorker，否则将 URL 放入队列中以供稍后处理。每次 TWorker 完成时，它都会检查队列中是否有要下载的新 URL，如果队列为空，则可以终止该 TWorker。

尝试这样的事情:

type
  TURLInfo = record 
    Index: Integer;
    Status: String;
    URL: String;
  end; 

...

private 
  LURLs: array of TURLInfo; 
  LURLQueue: TList;
  LWorkers : TList; 

...

uses
  ..., Worker;

const
  WM_REMOVE_WORKER := WM_USER + 100;

procedure TForm1.FormCreate(Sender: TObject); 
begin 
  LURLQueue := TList.Create;
  LWorkers := TList.Create; 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  LURLQueue.Free;
  LWorkers.Free; 
end; 

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  StopWorkers;
end;

procedure TForm1.WndProc(var Message: TMessage);
var
  Worker: TWorker;
begin
  if Message.Msg = WM_REMOVE_WORKER then
  begin
    Worker := TWorker(Message.LParam);
    if LWorkers.Remove(Worker) <> -1 then
    begin
      Worker.Stop;
      Worker.WaitFor;
      Worker.Free;
    end;
  end else
    inherited;
end;

procedure TForm1.ListViewData(Sender: TObject; Item: TListItem); 
var
  Index: Integer;
begin 
  Index := Item.Index;
  Item.Caption := IntToStr(LURLs[Index].Index); 
  Item.SubItems.Add(LURLs[Index].Status); 
  Item.SubItems.Add(LURLs[Index].URL); 
end; 

procedure TForm1.ClearURLs;
begin 
  StopWorkers;
  ListView.Items.Count := 0; 
  SetLength(LURLs, 0); 
end;

procedure TForm1.DownloadURL(Number: Integer);
var
  I: Integer;
  Worker: TWorker;
begin
  for I := 0 to LWorkers.Count-1 do
  begin
    Worker := TWorker(LWorkers[I]);
    if Worker.Idle then
    begin
      if Worker.Queue(LURLs[Number].URL, Number) then
        Exit;
    end;
  end;
  if LWorkers.Count < StrToInt(Threads.Text) then
  begin
    Worker := TWorker.Create;
    try
      Worker.OnStatus := WorkerStatus;
      Workers.Add(Worker);
    except
      Worker.Free;
      raise;
    end;
    Worker.Resume;
    if Worker.Queue(LURLs[Number].URL, Number) then
      Exit;
  end;

  LURLQueue.Add(TObject(Number));

  LURLs[Number].Status := 'Queued'; 
  ListView.UpdateItems(Number, Number); 
end;

procedure TForm1.DownloadURLs;
var
  I: Integer;
begin 
  LURLQueue.Clear;
  for I := 0 to High(LURLs) do
    DownloadURL(I);
end; 

procedure TForm1.StopWorkers;
var
  I: Integer;
  Worker: Tworker;
begin
  LURLQueue.Clear;

  for I := 0 to LWorkers.Count-1 do
    TWorker(LWorkers[I]).Stop;

  for I := 0 to LWorkers.Count-1 do
  begin
    Worker := TWorker(LWorkers[I]);
    Worker.WaitFor;
    Worker.Free;
  end;

  LWorkers.Clear;
end;

procedure TForm1.WorkerStatus(Sender: TWorker; APosition: Integer; const Status: String; Done: Boolean);
var
  URL: String;
  Number: Integer;
begin
  LURLs[APosition].Status := Status; 
  ListView.UpdateItems(APosition, APosition); 

  if not Done then Exit;

  if LURLQueue.Count = 0 then
  begin
    Sender.Stop;
    PostMessage(Handle, WM_REMOVE_WORKER, 0, Sender);
    Exit;
  end;

  Number := Integer(LURLQueue[0]);

  if Sender.Queue(LURLs[Number].URL, Number) then
    LURLQueue.Delete(0);
end;

.

unit Worker; 

interface 

uses
  Classes, SysUtils, HttpSend; 

type 
  TWorker = class;
  TWorkerStatusEvent = procedure(Sender: TWorker; ANumber: Integer; const Status: String; Done: Boolean) of object;

  TWorker = class(TThread) 
  private 
    { Private declarations } 
    Http: THTTPsend;
    Signal: TEvent;
    Number : Integer; 
    HtmlSourceCode : TStringList; 
    StatusMessage, URL : String; 
    StatusDone : Boolean; 
    FOnStatus: TWorkerEvent;
    procedure UpdateStatus(const Status: String; Done: Boolean); 
    procedure DoUpdateStatus; 
    procedure DownloadURL; 
  protected 
    procedure Execute; override; 
    procedure DoTerminate; override; 
  public 
    Idle: Boolean;
    constructor Create; 
    destructor Destroy; override; 
    function Queue(AURL: String; ANumber: Integer): Boolean;
    procedure Stop;
    property OnStatus: TWorkerStatusEvent read FOnStatus write FOnStatus;
  end; 

implementation 

constructor TWorker.Create; 
begin 
  inherited Create(True); 
  Signal := TEvent.Create(nil, False, False, '');
  Http := THTTPsend.Create;
  HtmlSourceCode := TStringList.Create; 
end; 

constructor TWorker.Destroy; 
begin 
  Signal.Free;
  HtmlSourceCode.Free; 
  Http.Free;
  inherited Destroy; 
end; 

function TWorker.Queue(AURL: String; ANumber: Integer): Boolean;
begin
  if (not Terminated) and Idle then
  begin
    URL := AURL; 
    Number := ANumber;
    Signal.SetEvent;
    Result := True;
  end else
    Result := False;
end;

procedure TWorker.Stop;
begin
  Terminate;
  Signal.SetEvent;
end;

procedure TWorker.UpdateStatus(const Status: String; Done: Boolean); 
begin
  if Assigned(FOnStatus) then
  begin
    StatusMessage := Status;
    StatusDone := Done;
    Synchronize(DoUpdateStatus); 
  end;
end;

procedure TWorker.DoUpdateStatus; 
begin 
  if Assigned(FOnStatus) then
    FOnStatus(Self, Number, StatusMessage, StatusDone);
end; 

var
  HtmlFileName: String;

procedure TWorker.Execute; 
begin 
  Randomize; 
  while not Terminated do
  begin
    Idle := True;

    if Signal.WaitFor(Infinite) <> wrSignaled then Exit;
    if Terminated then Exit;

    Idle := False;
    try
      try
        UpdateStatus('Working...', False); 
        if Terminated then Exit;

        // initialize THTTPsend...
        // download URL...
        // parse HTML...
        //
        HtmlSourceCode.LoadFromFile(HtmlFileName); 
        Sleep(1000+Random(1500)); // Only for simulation 

        UpdateStatus('Success', True); 
      finally
        HtmlSourceCode.Clear; 
      end;
    except
      UpdateStatus('Error', True); 
    end;
  end;
end; 

procedure TWorker.DoTerminate;
begin
  Idle := False;
  Terminate;
  inherited;
end; 

initialization
  HtmlFileName := ExtractFilePath(ParamStr(0)) + 'testfile.html';

end.