Delphi带运行时包的DLL中TThreadPool析构函数死锁求解决方案

核心问题 #

RTL库实现存在冲突：TThreadPool析构函数与FreeLibrary的限制交互时会引发死锁。Delphi 11 Update 3中，TThreadPool.Destroy方法加入了修复逻辑，核心是IsDLLDetaching判断分支：

unit System.Threading;

destructor TThreadPool.Destroy;
var
  I: Integer;
  Thread: TBaseWorkerThread;
  LocalFreeList: TList<TBaseWorkerThread>;
begin
  FShutdown := True;
{$IFDEF MSWINDOWS}
  if IsDLLDetaching then
  begin
    if (ThreadPoolMonitorHandles <> nil) and ThreadPoolMonitorHandles.ContainsKey(self) then
    begin
      TerminateThread( ThreadPoolMonitorHandles[self], 0);
      ThreadPoolMonitorHandles.Remove(self);
    end;
    with FThreads.LockList do
    try
      for I := 0 to Count - 1 do
        TerminateThread( Items[I].Handle, 0 );
    finally
      FThreads.UnLockList;
    end;
    FWorkerThreadCount := 0;
  end
  else
{$ENDIF MSWINDOWS}
  begin
    if FQueue <> nil then
    begin
      TMonitor.Enter(FQueue);
      try
        TMonitor.PulseAll(FQueue);
      finally
        TMonitor.Exit(FQueue);
      end;
    end;
    if FThreads <> nil then
    begin
      LocalFreeList := TList<TBaseWorkerThread>.Create;
      try
        with FThreads.LockList do
        try
          // Check each thread to see if it is already marked for termination and/or if it is hung.
          for I := 0 to Count - 1 do
          begin
            Thread := Items[I];
            LocalFreeList.Add(Thread);
          end;
        finally
          FThreads.UnlockList
        end;
        for I := 0 to LocalFreeList.Count - 1 do
          LocalFreeList[I].DisposeOf;
      finally
        LocalFreeList.Free;
      end;
    end;
    Assert(FWorkerThreadCount = 0);
    WaitMonitorThread;
  end;
  FThreads.Free;
  FQueue.Free;
  FQueues.Free;
  FRetiredThreadWakeEvent.Free;
  inherited;
end;

修复失效原因 #

在启用BPL的构建中，上述修复未按预期生效。问题根源在于Delphi开发团队将修复逻辑依赖于System.IsLibrary全局标志——由于rtl.bpl是共享组件，谁先加载它就决定了该标志的取值（本例中控制台程序先加载rtl.bpl），导致DLL中的IsDLLDetaching分支无法触发，最终引发死锁。

复现步骤 #

1. 控制台程序（加载并调用DLL） #

program ThreadPool;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  Winapi.Windows,
  System.Threading;

procedure DoSomeTasksFromDll();
var
  lHandle: Cardinal;
  lProc : procedure;
begin
  Writeln('Calling LoadLibrary()');
  lHandle := LoadLibrary('threadlib.dll');
  Writeln('LoadLibrary() = ', lHandle);

  Writeln('Calling GetProcAddress()');
  lProc := GetProcAddress(lHandle, 'DoSomeTasks');
  Writeln('GetProcAddress() = ', NativeInt(@lProc));

  Writeln('Calling DoSomeTasks()');
  lProc();
  WriteLn('DoSomeTasks() done');

  WriteLn('Calling FreeLibrary()');
  FreeLibrary(lHandle); // App will freeze here forever 
  WriteLn('FreeLibrary() done');
end;

begin
  try
    // Has no effect :(
    System.IsLibrary := true;
    WriteLn('System.IsLibrary: ', System.IsLibrary);

    WriteLn('Current thread: ', GetCurrentThreadId());
    DoSomeTasksFromDll();
  except
    on E: Exception do
      Writeln(E.ClassName, ': ', E.Message);
  end;

  Writeln('Any key pls');
  readln;
end. 

2. 带RTL/VCL运行时包的DLL #

library threadlib;

uses
  System.SysUtils,
  System.Threading,
  System.Generics.Collections;

{$R *.res}

procedure DoSomeTasks();
var
  lTaskList: TList<ITask>;
begin
  lTaskList := TList<ITask>.Create;
  try
    for var i := 0 to 2 do
    begin
      lTaskList.Add(TTask.Run(procedure
      begin
       Sleep(100);
      end));
    end;

    try
      TTask.WaitForAll(lTaskList.ToArray());
    except
      on e: Exception do Writeln(E.ClassName, ': ', E.Message);
    end;
  finally
    lTaskList.Free;
  end;
end;

exports
  DoSomeTasks;

begin
end.

运行输出 #

System.IsLibrary: TRUE
Current thread: 19340
Calling LoadLibrary()
LoadLibrary() = 2072182784
Calling GetProcAddress
GetProcAddress() = 2072197228
Calling DoSomeTasks()
DoSomeTasks() done
Calling FreeLibrary()

程序执行到FreeLibrary时永久冻结，恳请提供可行的解决方案。

内容的提问来源于stack exchange，提问作者Igor Kaplya