TRTTIContext多线程问题

Question

我读过的所有内容都表明TRTTIContext是线程安全的.

但是,当多线程时,TRTTIContext.FindType似乎偶尔会失败(返回nil).在它周围使用TCriticalSection可以解决问题.请注意,我正在使用XE6,并且XE中似乎不存在该问题.编辑:似乎存在于所有具有新RTTI单元的Delphi版本中.

我已经编写了一个测试项目,你可以用来亲自看看.创建一个新的VCL项目,删除TMemo和TButton,用下面替换unit1,并分配Form1.OnCreate,Form1.OnDestroy和Button1.OnClick事件.密钥CS是TTestThread.Execute中的GRTTIBlock.目前已禁用,当我运行200个线程时,我得到3到5个失败.启用GRTTIBlock CS可以消除故障.

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, SyncObjs, Contnrs, RTTI;

type
  TTestThread = class(TThread)
  private
    FFailed: Boolean;
    FRan: Boolean;
    FId: Integer;
  protected
    procedure Execute; override;
  public
    property Failed: Boolean read FFailed;
    property Ran: Boolean read FRan;
    property Id: Integer read FId write FId;
  end;

  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FThreadBlock: TCriticalSection;
    FMaxThreadCount: Integer;
    FThreadCount: Integer;
    FRanCount: Integer;
    FFailureCount: Integer;
    procedure Log(AStr: String);
    procedure ThreadFinished(Sender: TObject);
    procedure LaunchThreads;
  end;

var
  Form1: TForm1;

implementation

var
  GRTTIBlock: TCriticalSection;

{$R *.dfm}

{ TTestThread }

procedure TTestThread.Execute;
var
  ctx : TRTTIContext;
begin
//  GRTTIBlock.Acquire;
  try
    FFailed := not Assigned(ctx.FindType('Unit1.TForm1'));
    FRan := True;
  finally
//    GRTTIBlock.Release;
  end;
end;

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
  Randomize;
  LaunchThreads;
  Log(Format('Threads: %d, Ran: %d, Failures: %d',
    [FMaxThreadCount, FRanCount, FFailureCount]));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FThreadBlock := TCriticalSection.Create;
end;

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

procedure TForm1.Log(AStr: String);
begin
  Memo1.Lines.Add(AStr);
end;

procedure TForm1.ThreadFinished(Sender: TObject);
var
  tt : TTestThread;
begin
  tt := TTestThread(Sender);
  Log(Format('Thread %d finished', [tt.Id]));
  FThreadBlock.Acquire;
  try
    Dec(FThreadCount);
    if tt.Failed then
      Inc(FFailureCount);
    if tt.Ran then
      Inc(FRanCount);
  finally
    FThreadBlock.Release;
  end;
end;

procedure TForm1.LaunchThreads;
var
  c : Integer;
  ol : TObjectList;
  t : TTestThread;
begin
  FRanCount := 0;
  FFailureCount := 0;
  FMaxThreadCount := 200;
  ol := TObjectList.Create(False);
  try
    // get all the thread objects created and ready
    for c := 1 to FMaxThreadCount do
    begin
      t := TTestThread.Create(True);
      t.FreeOnTerminate := True;
      t.OnTerminate := ThreadFinished;
      t.Id := c;
      ol.Add(t);
    end;
    FThreadCount := FMaxThreadCount;
    // start them all up
    for c := 0 to ol.Count - 1 do
    begin
      TTestThread(ol[c]).Start;
      Log(Format('Thread %d started', [TTestThread(ol[c]).Id]));
    end;
    repeat
      Application.ProcessMessages;
      FThreadBlock.Acquire;
      try
        if FThreadCount <= 0 then
          Break;
      finally
        FThreadBlock.Release;
      end;
    until False;
  finally
    ol.Free;
  end;
end;

initialization
  GRTTIBlock := TCriticalSection.Create;

finalization
  GRTTIBlock.Free;

end.

Answer 1

我想我发现了这个问题.它在里面TRealPackage.FindType和MakeTypeLookupTable.

MakeTypeLookupTable检查是否FNameToType已分配.如果不是它运行DoMake.这一个受TMonitor保护,并FNameToType在进入后再次分配检查.

到现在为止还挺好.但随后发生错误,因为内部DoMake FNameToType被分配导致其他线程愉快地传递MakeTypeLookupTable并返回到FindType然后返回false FNameToType.TryGetValue并返回nil.

修复(希望对于XE8？):

由于FNameToType在锁定之外使用DoMake指示执行可以继续执行DoMake,因此在正确填充之前不应将其分配到内部.

编辑: 报告为https://quality.embarcadero.com/browse/RSP-9815

Answer 2

正如Stefan所解释的那样,问题在于双重检查锁定模式的错误实现.我想扩大他的答案,并试着让它更清楚是什么问题.

错误的代码如下所示:

procedure TRealPackage.MakeTypeLookupTable;

  procedure DoMake;
  begin
    TMonitor.Enter(Flock);
    try
      if FNameToType <> nil then // presumes double-checked locking ok
        Exit;

      FNameToType := TDictionary<string,PTypeInfo>.Create;
      // .... code removed from snippet that populates FNameToType
    finally
      TMonitor.Exit(Flock);
    end;
  end;

begin
  if FNameToType <> nil then
    Exit;
  DoMake;
end;

错误是填充共享资源的代码在分配FNameToType后执行FNameToType.填充共享资源的代码需要在FNameToType分配之前执行.

考虑两个线程,A和B.它们是第一个调用的线程MakeTypeLookupTable.线程A首先到达,发现FNameToType是nil和调用DoMake.线程A获取锁并到达分配的代码FNameToType.现在,在线程A设法运行更多代码之前,线程B到达MakeTypeLookupTable.它测试FNameToType并发现它不是nil,因此立即返回.然后调用代码使用FNameToType.但是,FNameToType还没有适合使用的状态.它尚未填充,因为线程A尚未返回.

Embarcadero方面最明显的解决方案如下:

procedure DoMake;
var
  LNameToType: TDictionary<string,PTypeInfo>;
begin
  TMonitor.Enter(Flock);
  try
    if FNameToType <> nil then // presumes double-checked locking ok
      Exit;

    LNameToType := TDictionary<string,PTypeInfo>.Create;
    // .... populate LNameToType
    FNameToType := LNameToType;
  finally
    TMonitor.Exit(Flock);
  end;
end;

但是,请注意说的假设双重检查锁定确定.好吧,当机器具有足够强大的内存模型时,双重检查锁定就可以了.所以它在x86和x64上都很好.但ARM的内存模型相对较弱.所以我对这个修复程序是否足以支持ARM有很强的疑虑.事实上,我确实想知道在Embarcadero中使用双重检查锁定的RTL中的其他地方.

如果TRealPackage已经在代码的接口部分声明了那么就可以很容易地修补TRealPackage.MakeTypeLookupTable以应用上面的更改.但事实并非如此.所以为了应用一个解决方案我建议如下:

1. 为您的所有RTTI代码使用单个全局RTTI上下文.
2. 在程序的初始化阶段,在该上下文上调用,然后强制调用TRealPackage.MakeTypeLookupTable.因为初始化发生单线程,所以你可以避免竞争条件

像这样声明全局上下文,说:

var
  ctx: TRttiContext;

并强制调用TRealPackage.MakeTypeLookupTable这样:

ctx.FindType('');

只要你的所有RTTI代码通过这个单独的共享上下文,那么你就不会违背这场比赛.