Problema multi-thread do TRTTIContext

Tudo o que li indica que o TRTTIContext é seguro para threads.

No entanto, TRTTIContext.FindType parece falhar (retorna nulo) ocasionalmente ao realizar multithreading. Usar um TCriticalSection em torno dele corrige o problema. Observe que estou usando o XE6 e o problema não parece existir no XE.Editar: Parece existir em todas as edições Delphi que possuem as novas unidades RTTI.

Elaborei um projeto de teste que você pode usar para ver por si mesmo. Crie um novo projeto VCL, descarte um TMemo e um TButton, substitua unit1 por abaixo e atribua os eventos Form1.OnCreate, Form1.OnDestroy e Button1.OnClick. A chave CS é o GRTTIBlock em TTestThread.Execute. Atualmente desativado, recebo entre 3 e 5 falhas quando executo com 200 threads. A ativação do GRTTIBlock CS remove as falhas.

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.

questionAnswers(2)

yourAnswerToTheQuestion