Virtual Listview, threads and memory consumption that doesn't go down

2018-05-31 01:55:13

*Update: Two people told me that it's hard to help me without the real/full code. You pretty much have it below, but in case I forgot anything, here it is! laserrental.ca/MemoryProblem.zip

Version of Delphi used: 2007

Hello,

I am new to threads and virtual listviews, so my problem might be simple to solve; however, I've been stuck for a few days. Basically, here is what I have:

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

The user clicks on Load URLs and the URLs are stocked in the following record:

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

...

var
 LURLs : Array of TVirtualList;

And the record is used to fill the Virtual Listview. Here is the OnData code:

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;

When the user clicks on GO , the app will launch one thread that will control the creation of worker threads. Each worker thread takes a URL, downloads it and parses it for getting further info.

Now, here is my problem: the memory consumption always gets higher and higher -- at least, according to the Task Manager. If I minimize the app and open it again, the memory consumption gets back to normal... but the virtual memory consumption stays super high. Now, I know many people say that the Task Manager is unreliable. Yet, after a while, the memory consumption gets so high that the URLs cannot be downloaded anymore. I get an EOutOfMemory error. My computer gets super slow.

According to FastMM4, there is no memory leak.

And here is the funny thing: if I clear the TVirtualList record, the memory consumption -- both the "normal" one and the virtual one -- gets back to normal. But unless I do that, it stays super high. Obviously, this is a problem since I want the app to be able to download thousands and thousands of URLs; but with this bug, I can't go too far.

Code to clear TVirtualList record

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

So I stripped down the app to the essential. There is no parsing and instead of downloading a file, the app loads a single local HMTL file with the use of critical sections. The memory consumption problem is still there.

Control thread:

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.

Worker thread:

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.

What you describe sounds like either a memory leak or memory fragmentation. Either way, it is hard to tell since you do not show how you are allocating and filling the URLs array itself.

I would suggest getting rid of TLoader completely and use a throttled queue instead. When downloading a url, check if an idle TWorker already exists and if so then let it download the URL, otherwise start a new TWorker if you have not reached your limit yet, otherwise put the URL into a queue for later processing. Each time a TWorker finishes, it can check the queue for a new URL to download, and if the queue is empty then that TWorker can be terminated.

Try something like this:

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.

链接地址: http://www.djcxy.com/p/5972.html

上一篇: 无法获得父母

下一篇: 虚拟列表视图，线程和内存消耗不下降