TRTTIContext多线程问题 [英] TRTTIContext multi-thread issue
问题描述
然而，当多线程时，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;
接口
使用
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：整数;
protected
procedure Execute;覆盖
public
属性失败：Boolean读取FFailed;
属性Ran：Boolean读取FRAN;
属性Id：整数读取FID写入FID;
结束
TForm1 = class（TForm）
Memo1：TMemo;
Button1：TButton;
procedure Button1Click（Sender：TObject）;
procedure FormCreate（Sender：TObject）;
procedure FormDestroy（Sender：TObject）;
private
FThreadBlock：TCriticalSection;
FMaxThreadCount：整数;
FThreadCount：整数;
FRANCount：整数;
FFailureCount：整数;
procedure Log（AStr：String）;
procedure ThreadFinished（Sender：TObject）;
程序LaunchThreads;
结束
var
Form1：TForm1;
实现
var
GRTTIBlock：TCriticalSection;
{$ R * .dfm}
{TTestThread}
程序TTestThread.Execute;
var
ctx：TRTTIContext;
begin
// GRTTIBlock.Acquire;
try
FFailed：= not Assigned（ctx.FindType（'Unit1.TForm1'））;
FRAN：= True;
finally
// GRTTIBlock.Release;
结束
结束
{TForm1}
程序TForm1.Button1Click（发件人：TObject）;
begin
随机化;
LaunchThreads;
Log（Format（'Threads：％d，Ran：％d，Failures：％d'，
[FMaxThreadCount，FRanCount，FFailureCount]））;
结束
procedure TForm1.FormCreate（Sender：TObject）;
begin
FThreadBlock：= TCriticalSection.Create;
结束
procedure TForm1.FormDestroy（Sender：TObject）;
begin
FThreadBlock.Free;
结束
程序TForm1.Log（AStr：String）;
begin
Memo1.Lines.Add（AStr）;
结束
procedure TForm1.ThreadFinished（Sender：TObject）;
var
tt：TTestThread;
begin
tt：= TTestThread（Sender）;
Log（Format（'Thread％d finished'，[tt.Id]））;
FThreadBlock.Acquire;
尝试
Dec（FThreadCount）;
如果tt.Failed然后
Inc（FFailureCount）;
如果tt.Ran然后
Inc（FRanCount）;
finally
FThreadBlock.Release;
结束
结束
程序TForm1.LaunchThreads;
var
c：整数;
ol：TObjectList;
t：TTestThread;
begin
FRanCount：= 0;
FFailureCount：= 0;
FMaxThreadCount：= 200;
ol：= TObjectList.Create（False）;
尝试
//获取所有创建的线程对象并准备
for c：= 1到FMaxThreadCount do
begin
t：= TTestThread.Create（True）;
t.FreeOnTerminate：= True;
t.OnTerminate：= ThreadFinished;
t.Id：= c;
ol.Add（t）;
结束
FThreadCount：= FMaxThreadCount;
//将它们全部启动
c：= 0到ol.Count - 1 do
begin
TTestThread（ol [c]）。
Log（Format（'Thread％d started'，[TTestThread（ol [c]）。Id]））;
结束
重复
Application.ProcessMessages;
FThreadBlock.Acquire;
尝试
如果FThreadCount <= 0则
休息;
finally
FThreadBlock.Release;
结束
until False;
finally
ol.Free;
结束
结束
初始化
GRTTIBlock：= TCriticalSection.Create;
finalization
GRTTIBlock.Free;
结束。
我想我发现了这个问题。它位于 TRealPackage.FindType 和 MakeTypeLookupTable 之内。
MakeTypeLookupTable 正在分配 FNameToType 。如果不运行 DoMake 。这一个被TMonitor保护，并在输入后再次分配 FNameToType 。
到目前为止这么好。但是然后发生错误，因为内部 DoMake FNameToType 被赋值，导致其他线程愉快地通过 MakeTypeLookupTable 并返回到 FindType ，然后在 FNameToType.TryGetValue 中返回false，并返回nil。
修复（希望为XE8？）：
由于 FNameToType 在锁定的 DoMake 之外使用，作为执行可以继续的指示器，不应在 DoMake ，直到它正确填满。
编辑：
报告为< a href =https://quality.embarcadero.com/browse/RSP-9815> https://quality.embarcadero.com/browse/RSP-9815
Everything I've read indicates that TRTTIContext is thread-safe.
However, TRTTIContext.FindType seems to fail (returns nil) occasionally when multithreading. Using a TCriticalSection around it fixes the issue. Note that I'm using XE6, and the issue doesn't seem to exist in XE. Edit: Seems to exist in all Delphi editions that have the new RTTI units.
I've worked up a test project you can use to see for yourself. Create a new VCL project, drop a TMemo and a TButton, replace unit1 with below, and assign the Form1.OnCreate, Form1.OnDestroy and Button1.OnClick events. The key CS is the GRTTIBlock in TTestThread.Execute. Currently disabled, I get between 3 and 5 failures when I run with 200 threads. Enabling the GRTTIBlock CS removes the failures.
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.
I think I found the problem. It is inside TRealPackage.FindType and MakeTypeLookupTable.
MakeTypeLookupTable checks for FNameToType being assigned. If not it runs DoMake. This one is protected with TMonitor and checks FNameToType being assigned again after entering.
So far so good. But then happens the mistake as inside DoMake FNameToType gets assigned causing other threads to happily pass MakeTypeLookupTable and return to FindType which then does return false in FNameToType.TryGetValue and returns nil.
Fix (hopefully for XE8?):
Since FNameToType is used outside of the locked DoMake as indicator that execution can continue it should not be assigned inside DoMake until it's properly filled up.
Edit: Reported as https://quality.embarcadero.com/browse/RSP-9815
这篇关于TRTTIContext多线程问题的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
