TRTTIContext многопоточный выпуск

Все, что я прочитал, указывает на то, что TRTTIContext является поточно-ориентированным.

Тем не менее, TRTTIContext.FindType, кажется, иногда завершается ошибкой (возвращает ноль) при многопоточности. Использование TCriticalSection вокруг этого исправляет проблему. Обратите внимание, что я использую XE6, и проблема, похоже, не существует в XE. Изменить: Кажется, существует во всех выпусках Delphi, которые имеют новые модули RTTI.

Я разработал тестовый проект, который вы можете использовать, чтобы убедиться в этом. Создайте новый проект VCL, удалите TMemo и TButton, замените unit1 на нижнее и назначьте события Form1.OnCreate, Form1.OnDestroy и Button1.OnClick. Ключ CS - это GRTTIBlock в TTestThread.Execute. В настоящее время отключено, я получаю от 3 до 5 сбоев при работе с 200 потоками. Включение 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.
Источник

2 ответа

Решение

Я думаю, что нашел проблему. Это внутри TRealPackage.FindType а также MakeTypeLookupTable,

MakeTypeLookupTable проверяет FNameToType быть назначенным. Если не он работает DoMake, Этот защищен TMonitor и проверяет FNameToType назначается снова после входа.

Все идет нормально. Но тогда случается ошибка, как внутри DoMakeFNameToType получает назначение, заставляя другие потоки счастливо проходить MakeTypeLookupTable и вернуться к FindType который затем возвращает ложь в FNameToType.TryGetValue и возвращает ноль.

Исправить (надеюсь, для XE8?):

поскольку FNameToType используется за пределами запертой DoMake как индикатор того, что исполнение может продолжаться, его не следует назначать внутри DoMake пока он не заполнится должным образом.

Изменить: зарегистрировано как https://quality.embarcadero.com/browse/RSP-9815

Источник

Как объясняет Стефан, проблема заключается в неправильной реализации шаблона двойной проверки блокировки. Я хотел бы расширить его ответ и попытаться прояснить, в чем дело.

Ошибочный код выглядит так:

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, Поток А прибывает первым, находит, что FNameToType является nil и звонки DoMake, Поток A получает блокировку и достигает кода, который назначает FNameToType, Теперь, прежде чем потоку А удастся выполнить больше кода, поток 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. Действительно, мне интересно, где еще в RTL Embarcadero использовал двойную проверку блокировки.

Если TRealPackage было объявлено в разделе интерфейса кода, тогда будет достаточно легко исправить TRealPackage.MakeTypeLookupTable применить изменения выше. Однако это не так. Поэтому, чтобы применить обходной путь, я предлагаю следующее:

  1. Используйте единый глобальный контекст RTTI для всего вашего кода RTTI.
  2. На этапе инициализации вашей программы вызовите этот контекст, который, в свою очередь, вызовет вызов TRealPackage.MakeTypeLookupTable, Поскольку инициализация происходит однопоточно, вы избегаете условия гонки.

Объявите глобальный контекст следующим образом:

var
  ctx: TRttiContext;

И заставить вызов TRealPackage.MakeTypeLookupTable как это:

ctx.FindType('');

До тех пор, пока весь ваш код RTTI проходит через этот единый общий контекст, вы не можете быть недовольны этой гонкой.

Источник
Другие вопросы по тегам