Многопоточная проблема TRTTIContext

Question

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

Однако TRTTIContext.FindType иногда терпит неудачу (возвращает nil) изредка при многопоточности. Использование 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. 

Answer 1

Думаю, что я нашел проблему. Он находится внутри TRealPackage.FindType и MakeTypeLookupTable.

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

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

Fix (надеюсь на X Е8):

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

Edit: Сообщается также https://quality.embarcadero.com/browse/RSP-9815

Answer 2

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

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

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

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

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

Объявляем глобальный контекст, как это, скажем:

var 
    ctx: TRttiContext; 

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

ctx.FindType(''); 

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