虚拟列表视图、线程和内存消耗不下降

Question

*更新：两个人告诉我没有真实/完整的代码很难帮助我。你几乎已经有了它，但以防万一我忘记了什么，这里是！laserrental.ca/MemoryProblem.zip

---

使用的Delphi版本：2007

你好，

我对线程和虚拟列表视图都很陌生，所以我的问题可能很容易解决；然而，我已经卡了几天了。基本上，这就是我的问题：

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

用户点击“加载URLs”，URL将被存储在以下记录中：

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

...

var
 LURLs : Array of TVirtualList;

记录用于填充虚拟列表视图。以下是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 错误。我的电脑变得超级缓慢。

根据 FastMM4 的说法，没有内存泄漏。

而有趣的是：如果我清除 TVirtualList 记录，则内存消耗（包括“正常”的和虚拟的）都会恢复正常。但如果不这样做，它就会保持非常高。显然，这是一个问题，因为我希望该应用程序能够下载数千个 URL，但由于这个错误，我不能走太远。

清除 TVirtualList 记录的代码如下：

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

---

我将这个应用程序简化到了必要的程度。没有解析，而是使用关键部分加载单个本地HTML文件，而不是下载文件。内存消耗问题仍然存在。

---

控制线程：

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.

- Pascal Bergeron

---

听起来你的内存不够用了。尽量不要分配太多内存。最小化应用程序将修剪工作集，但你只能保留那么多虚拟内存。在上面的代码中，内存是在哪里分配的？ - David Heffernan

TStringList.Free工作正常。您显然已经删除了分配动态数组的代码。当内存不足时，它有多大？您还删掉了HTML解析。那会消耗内存吗？没有真正的代码很难提供帮助。 - David Heffernan

我的观点是，那段代码——没有 Synapse 和 HTML 的东西——导致了错误。我不想用无用的 Synapse 和解析代码来困扰人们。这会让阅读变得更加冗长，我真的很感激你们的帮助。之前，我说过“我相信没有代码来分配内存。”我可能错了，但我不认为有任何具体的代码。如果您想看一下，我在开头放了完整的源代码。 - Pascal Bergeron

ZIP文件中的内容与我所拥有的完全一样。URLs文件使用TStringList加载。然后，我使用SetLength(LURLs, TStringList.Count)来设置LURLs的长度。然后，通过使用TStringList来填充每个LURLs数组。要运行它，您点击“加载URLs”。您加载虚假的“filetoload.txt”，然后点击“GO”。我一次创建200个线程，是的。当然，我会尝试Remy的建议。他的系统似乎更明智。 - Pascal Bergeron

我还剩5分钟，计时中。没有异常行为。内存状态稳定。我使用的是Win7 x64系统。我会看一下Delphi 6对此的反应。 - David Heffernan

Answer 1

你所描述的情况听起来像是内存泄露或内存碎片化。无论哪种情况，由于你没有展示如何分配和填充URL数组本身，因此很难确定。

我建议彻底摆脱TLoader并改用受限队列。当下载一个URL时，请检查是否已经存在空闲的TWorker，如果有，则让它下载该URL，否则，如果你还没有达到极限，则启动一个新的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. 

- Remy Lebeau

---

我会尝试按照你说的改变整个结构。如果有需要，你可以在源代码开头找到完整的源代码。 - Pascal Bergeron