delphi XE4多线程critical section问题

Posted 2023-04-12

有栅格图像一幅（每个栅格代表一个像素，有9000行*6000列），现在要设置两个thread来对图像进行处理，以提高每一行每一行读取的效率，想让两个thread同时处理，结果各种阴差阳错吧，两个thread设置成了一个先进来对图像的一行进行处理，另一个等这个处理完了之后再处理下一行，总之这样交替进行。我知道这样会很慢，但是老板（也就是教授）觉得反正都这样了，就看看能有多慢。但是由于我不是计算机系出身也没学过delphi，这个多线程看的我云里雾里。之前代码如下：
这是thread里面处理图像的过程，我老板说critical section写的不对：

这是主函数里面设置的thread：

现在就是不晓得应该怎么改了，求大神指教哇！要代码，不要思路了，因为比较着急。还有就是因为我在国外，所以压缩文件里面希望能加上代码的截图，这样中文注释就不会在解压缩的过程中变乱码了

参考技术A 无法给你代码，别急，越急越解决不了问题，找本书研究下线程，现在你的上述逻辑有问题。

按你的意思，2个线程同时工作的话逻辑应该是:线程1做完了，线程1应该就要等待，然后线程2做，线程2做完了，就等待，线程1做。

在线程1做完了就关掉（就是线程1做完了，线程1等待），在Execute里面写FreeOnTerminate：=True,在Thread1Done里面启动线程2，线程2的Thread2Done里面启动线程1.循环。。。。临界区都不要。
逻辑才不会乱，你现在用一个Execute函数（当然是一个） 用一个ThreadDone 。。当然各种阴差阳错。

//leaveCriticalSection写到Thread1Done 和 Thread2Done 里面去。

TRTTIContext 多线程问题

【中文标题】TRTTIContext 多线程问题

【英文标题】：TRTTIContext multi-thread issue

【发布时间】：2015-02-06 17:34:03

【问题描述】：

我读过的所有内容都表明 TRTTIContext 是线程安全的。

但是，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;

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.

【问题讨论】：

我个人认为最好有一个全局上下文变量。似乎 FThreadBlock 没有任何作用。您将受益于此处的TList<T> 而不是TObjectList。

ctx 是从池中创建的。它有一个引用计数机制，它的创建和销毁由 AtomicCmpExchange 调用保护。您在此测试中对系统施加了很大的压力。顺便说一句，FThreadBlock 总是在主线程中使用，并且不需要。

@Deltics，来自类单元：procedure TThread.DoTerminate;如果已分配（FOnTerminate）则开始，然后同步（CallOnTerminate）；结束;

@Deltics：TThread.Terminate() 根本没有同步。它所做的只是直接为TThread.Terminated 属性赋值。 TThread.DoTerminate() 在工作线程的上下文中调用，而TThread.OnTerminate 在主线程的上下文中调用（除非您覆盖DoTerminate() 以直接调用OnTerminate）。线程析构函数在线程上下文是否调用线程对象上的Free/Destroy()时调用线程析构函数，FreeOnTerminate为真时为工作线程本身，否则为不同的线程上下文。

这个问题在 Delphi 10 Seattle 中仍然存在

【参考方案1】：

我想我找到了问题所在。它在TRealPackage.FindType 和MakeTypeLookupTable 内。

MakeTypeLookupTable 检查是否分配了FNameToType。如果不是，它运行DoMake。这个受TMonitor保护，进入后会检查FNameToType是否被再次分配。

到目前为止一切顺利。但是随后发生了错误，因为DoMake 内部的FNameToType 被分配导致其他线程愉快地通过MakeTypeLookupTable 并返回FindType，然后在FNameToType.TryGetValue 中返回false 并返回nil。

修复：

由于FNameToType 在锁定的DoMake 之外使用作为可以继续执行的指示符，因此不应在DoMake 内分配，直到它被正确填满。

编辑： 举报为https://quality.embarcadero.com/browse/RSP-9815

最近（截至 2019 年 11 月）在 Delphi 10.3 Rio 中标记为已修复。

【讨论】：

您可以在回答中注明这会影响自 D2010 以来的所有 Delphi 版本，并且全局上下文变量也会失败。

@Stefan 我认为您的错误报告可以改进。我认为工程师不会理解它并且可能不会应用修复并不是难以置信的。我建议您添加一个包含故障再现的步骤部分。此处问题中提供的代码显示了如何做到这一点。更重要的是，我还鼓励您包含指向此问题的链接，以及来自TRealPackage.MakeTypeLookupTable 的摘录，以明确问题所在。您描述了这个问题，但包含代码提供了更多功能。最后，我有点害怕 ARM 上的双重检查锁定。

在 10.3 rio 中已修复。

【参考方案2】：

正如 Stefan 所解释的，问题归结于双重检查锁定模式的错误实现。我想扩展他的答案，并尝试更清楚地说明问题所在。

错误代码如下所示：

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 的线程。线程A先到，发现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;

但是，请注意说 presumes double-checked locking ok 的注释。好吧，当机器有足够强大的内存模型时，双重检查锁定是可以的。所以在 x86 和 x64 上一切都很好。但 ARM 的内存模型相对较弱。所以我强烈怀疑这个修复在 ARM 上是否足够。事实上，我确实想知道 Embarcadero 在 RTL 中的其他什么地方使用了双重检查锁定。

如果TRealPackage 已在代码的接口部分声明，那么修补TRealPackage.MakeTypeLookupTable 以应用上述更改就很容易了。然而，事实并非如此。因此，为了解决问题，我建议如下：

为所有 RTTI 代码使用一个全局 RTTI 上下文。 在程序的初始化阶段，对该上下文进行调用，进而强制调用TRealPackage.MakeTypeLookupTable。因为初始化发生在单线程中，所以可以避免竞争条件。

像这样声明全局上下文，比如：

var
  ctx: TRttiContext;

然后像这样强制调用TRealPackage.MakeTypeLookupTable：

ctx.FindType('');

只要你所有的 RTTI 代码都通过这个单一的共享上下文，那么你就不会在这场竞赛中犯规。

【讨论】：

是的，解决了这个问题！现在要提交一些补丁;)

RTL 中本地声明的上下文变量怎么样？似乎它会影响 Rest/Soap/JSON。

@LURD 当然。对于您无法控制的 RTTI 上下文，您无能为力。设计师真的搞砸了。他们应该强制执行上下文的单个共享全局实例。为什么他们认为我们都需要我们自己的实例，这些实例在编译时已修复，这超出了我的理解。

只有一个我们真正需要的 TRttiPool 的共享全局实例。所以只要你足够早让它加载你就可以了。