以多线程方式使用Delphi7 COM接口时的内存消耗

时间：2013-10-30 04:03:01

标签： multithreading delphi memory com xmldocument

在以多线程方式访问COM和IXMLDocument等IXMLNode对象接口时，Delphi7中似乎存在一些内存问题。其他COM interfaces可能会分享这个问题，但我的“研究”并不是那么深刻，因为我必须继续我当前的项目。创建TXMLDocument并在单个线程上通过IXMLDocument和IXMLNode等接口操作它是可以的，但在多线程方法中，当一个线程创建TXMLDocument对象和其他线程时操纵它使用越来越多的内存。 CoInitializeEx(nil, COINIT_MULTITHREADED)在每个帖子中被调用但是徒劳无功。似乎每个线程在获取接口时都会分配一些内存并且不释放它，但是每个线程都会分配一次 - 至少对于某个接口 - 例如DocumentElement或ChildNodes - 在创建对象的线程旁边有一个工作线程 - 不会导致可见内存泄漏。但是动态创建的线程的行为方式都相同，最终消耗了进程内存。

这是我的完整测试应用程序Delphi7 form作为SCCE，它试图显示上面提到的三种不同场景 - 单线程，一个工作线程和动态创建的线程。 

unit uComTest;

interface

uses 
  Windows, SysUtils, Classes, Forms, ExtCtrls, Controls, StdCtrls, XMLDoc, XMLIntf,            ActiveX;

type

  TMyThread = class(TThread)
    procedure Execute;override;
  end;

  TForm1 = class(TForm)

    btnMainThread: TButton;
    edtText: TEdit;
    Timer1: TTimer;
    btnOneThread: TButton;
    btnMultiThread: TButton;
    Timer2: TTimer;
    chkXMLUse: TCheckBox;

    procedure FormCreate(Sender: TObject);
    procedure btnMainThreadClick(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnOneThreadClick(Sender: TObject);
    procedure btnMultiThreadClick(Sender: TObject);
    procedure Timer2Timer(Sender: TObject);

  private

    fXML:TXMLDocument;
    fXMLDocument:IXMLDocument;
    fThread:TMyThread;
    fCount:Integer;
    fLoop:Boolean;

    procedure XMLCreate;
    function XMLGetItfc:IXMLDocument;
    procedure XMLUse;

  public

end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject); 
begin
  CoinitializeEx(nil, COINIT_MULTITHREADED);
  XMLCreate; //XML is created on MainThread;
  Timer1.Enabled := false;
  Timer2.Enabled := false;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  fIXMLDocument := nil;
  CoUninitialize;
end;

procedure TForm1.XMLCreate;
begin
  fXML := TXMLDocument.Create('.\try.xml');
  fXML.Active;
  fXML.GetInterface(IXMLDocument, fIXMLDocument);
end;

function TForm1.XMLGetItfc:IXMLDocument;
begin
  fXML.GetInterface(IXMLDocument, Result); 
end;

procedure TForm1.XMLUse;
begin
  Inc(fCount);

  if chkXMLUse.Checked then
  begin
    XMLGetItfc.DocumentElement;
    edtText.Text := IntToStr(GetCurrentThreadId) + ': ' + 'XML access  ' + IntToStr(fCount);
  end
  else
    edtText.Text := IntToStr(GetCurrentThreadId) + ': ' + 'NO XML access  ' +   IntToStr(fCount)
end;

procedure TForm1.btnMainThreadClick(Sender: TObject);
begin
  fCount := 0;
  fLoop := false;
  Timer1.Enabled := not Timer1.Enabled;
end;

procedure TForm1.btnOneThreadClick(Sender: TObject);
begin
  if fLoop then
    fLoop := false
  else
  begin
    fCount := 0;
    fLoop := true;
    fThread := TMyThread.Create(FALSE);
  end;
end;

procedure TForm1.btnMultiThreadClick(Sender: TObject);
begin
  fCount := 0;
  fLoop := false;
  Timer2.Enabled := not Timer2.Enabled;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  XMLUse;
end;

procedure TForm1.Timer2Timer(Sender: TObject);
begin
  TMyThread.Create(FALSE);
end;

//this procedure executes in every thread
procedure TMyThread.Execute;
begin
  FreeOnTerminate := TRUE;
  CoinitializeEx(nil, COINIT_MULTITHREADED);
  try
    repeat
      Form1.XMLUse;
      if Form1.floop then
        sleep(100);
    until not Form1.floop;
  finally
    CoUninitialize;
  end;
end;

end.

嗯，这不仅仅是因为它是一个工作的Delphi表单buttons和timers而且更少，因为你不能只复制和编译它。这也是form的dfm：

object Form1: TForm1
  Left = 54
  Top = 253
  Width = 337
  Height = 250
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object btnMainThread: TButton
    Left = 24
    Top = 32
    Width = 75
    Height = 25
    Caption = 'MainThread'
    TabOrder = 0
    OnClick = btnMainThreadClick
  end
  object edtText: TEdit
    Left = 24
    Top = 8
    Width = 257
    Height = 21
    TabOrder = 1
  end
  object btnOneThread: TButton
    Left = 24
    Top = 64
    Width = 75
    Height = 25
    Caption = 'One Thread'
    TabOrder = 2
    OnClick = btnOneThreadClick
  end
  object btnMultiThread: TButton
    Left = 24
    Top = 96
    Width = 75
    Height = 25
    Caption = 'MultiThread'
    TabOrder = 3
    OnClick = btnMultiThreadClick
  end
  object chkXMLUse: TCheckBox
    Left = 112
    Top = 88
    Width = 97
    Height = 17
    Caption = 'XML use'
    Checked = True
    State = cbChecked
    TabOrder = 4
  end
  object Timer1: TTimer
    Interval = 100
    OnTimer = Timer1Timer
  end
  object Timer2: TTimer
    Interval = 100
    OnTimer = Timer2Timer
    Left = 32
  end
end

这是一个控制台应用程序。只需运行它，看看是否有任何内存消耗。如果您认为它可以编写为保留多线程但不占用内存的方式，则可以根据需要进行修改：

program ConsoleTest;

{$APPTYPE CONSOLE}

uses

  Windows, SysUtils, Classes, XMLDoc, XMLIntf, ActiveX;

type

  TMyThread = class(TThread)

    procedure Execute;override;

  end;

var
  fCriticalSection:TRTLCriticalSection;
  fIXMLDocument:IXMLDocument;
  i:Integer;

//--------- Globals -------------------------------
procedure XMLCreate;
begin
  fIXMLDocument := TXMLDocument.Create('.\try.xml');
  fIXMLDocument.Active;
end;

procedure XMLUse;
begin
  fIXMLDocument.DocumentElement;
end;

//------- TMyThread ------------------------------
procedure TMyThread.Execute;
begin
  FreeOnTerminate := TRUE;

  EnterCriticalSection(fCriticalSection);
  try
    CoinitializeEx(nil, COINIT_MULTITHREADED);
    try
      XMLUse;
    finally
      CoUninitialize;
    end;
  finally
    LeaveCriticalSection(fCriticalSection);
  end;
end;

//------------ Main -------------------------
begin
  InitializeCriticalSection(fCriticalSection);
  CoinitializeEx(nil, COINIT_MULTITHREADED);
  try
    XMLCreate;
    try
      for i := 0 to 100000 do
      begin
        TMyThread.Create(FALSE);
        sleep(100);
      end;
    finally
      fIXMLDocument := nil;
    end;
  finally
    CoUninitialize;
    DeleteCriticalSection(fCriticalSection);
  end;
end.

我在Windows7上使用Delphi7 Enterprise。 任何帮助都非常受欢迎。

3 个答案:

答案 0 :(得分：5)

您正在使用自由线程的线程模型。在调用TXMLDocument.Create时创建单个COM对象。然后，您可以从多个线程使用该对象而无需任何同步。换句话说，您违反了COM线程规则。可能会遇到更多问题，但在处理此问题之前，您不能指望继续进行。

答案 1 :(得分：0)

问题没有得到解决，问题仍未得到解决。但我必须自己解决它，所以最终我决定切换到另一个XML实现。我的选择是OmniXML，内存消耗现在消失了。

答案 2 :(得分：0)

这不是解决此问题的真正解决方案，但我通过它在主线程上启动IXMLDocument实例并在调用resume之前将其引用传递给新创建的动态线程。使用这种方法，IXMLDocument的所有引用都保留在mainthread上，因此当引用计数变为零时，Delphi可以处理所有引用。

相关问题
最新问题