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.