*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.