multithreading - WaitForSingleObject 返回 WAIT_OBJECT_0 但未调用 SetEvent

Question

在一个不断创建和销毁许多线程的程序中，有时 WaitForSingleObject() 返回 WAIT_OBJECT_0，但未调用预期事件的 SetEvent()。我试图在网上查找资料，但找不到类似的WaitForSingleObject() bug。

我编写了一个小的测试应用程序，其中出现了这个错误。

事件测试.dpr:

program EventsTest;

{$APPTYPE CONSOLE}
{$R *.res}

uses
  System.SysUtils,
  Windows,
  CallBack in 'CallBack.pas',
  MainThread in 'MainThread.pas',
  WorkThread in 'WorkThread.pas';

procedure Init;
var
  HStdin: THandle;
  OldMode: Cardinal;
begin
  HStdin := GetStdHandle(STD_INPUT_HANDLE);
  GetConsoleMode(HStdin, OldMode);
  SetConsoleMode(HStdin, OldMode and not (ENABLE_ECHO_INPUT));

  InitCallBacks;
  InitMainThread;
end;

procedure Done;
begin
  DoneMainThread;
  DoneCallBacks;
end;

procedure Main;
var
  Command: Char;
begin
  repeat
    Readln(Command);
    case Command of
      'q': Exit;
      'a': IncWorkThreadCount;
      'd': DecWorkThreadCount;
    end;
  until False;
end;

begin
  try
    Init;
    try
      Main;
    finally
      Done;
    end;
  except
    on E: Exception do Writeln(E.ClassName, ': ', E.Message);
  end;
end.

主线程.pas:

unit MainThread;

interface

procedure InitMainThread;
procedure DoneMainThread;
procedure IncWorkThreadCount;
procedure DecWorkThreadCount;

implementation

uses
  SysUtils, Classes, Generics.Collections,
  Windows,
  WorkThread;

type

{ TMainThread }

  TMainThread = class(TThread)
  private
    FThreadCount: Integer;
  protected
    procedure Execute; override;
  public
    constructor Create;
    destructor  Destroy; override;
  end;

constructor TMainThread.Create;
begin
  inherited Create(False);
  FThreadCount := 100;
end;

destructor TMainThread.Destroy;
begin
  inherited;
end;

procedure TMainThread.Execute;
var
  I: Integer;
  ThreadList: TList<TWorkThread>;
  ThreadLoopList: TList<TWorkLoopThread>;
begin
  NameThreadForDebugging('MainThread');

  ThreadLoopList := TList<TWorkLoopThread>.Create;
  try
    ThreadLoopList.Count := 200;
    for I := 0 to ThreadLoopList.Count - 1 do
      ThreadLoopList[I] := TWorkLoopThread.Create;

    ThreadList := TList<TWorkThread>.Create;
    try
      while not Terminated do
      begin
        ThreadList.Count := FThreadCount;

        for I := 0 to ThreadList.Count - 1 do
          ThreadList[I] := TWorkThread.Create;

        Sleep(1000);

        for I := 0 to ThreadList.Count - 1 do
          ThreadList[I].Terminate;

        for I := 0 to ThreadList.Count - 1 do
        begin
          ThreadList[I].WaitFor;
          ThreadList[I].Free;
          ThreadList[I] := nil;
        end;
      end;
    finally
      ThreadList.Free;
    end;

    for I := 0 to ThreadLoopList.Count - 1 do
    begin
      ThreadLoopList[I].Terminate;
      ThreadLoopList[I].WaitFor;
      ThreadLoopList[I].Free;
    end;
  finally
    ThreadLoopList.Free;
  end;
end;

var
  Thread: TMainThread;

procedure InitMainThread;
begin
  Thread := TMainThread.Create;
end;

procedure DoneMainThread;
begin
  Thread.Terminate;
  Thread.WaitFor;
  Thread.Free;
end;

procedure IncWorkThreadCount;
begin
  InterlockedIncrement(Thread.FThreadCount);
  Writeln('IncWorkThreadCount');
end;

procedure DecWorkThreadCount;
begin
  Writeln('DecWorkThreadCount');
  if Thread.FThreadCount > 0 then
    InterlockedDecrement(Thread.FThreadCount);
end;

end.

工作线程.pas:

unit WorkThread;

interface

uses
  SysUtils, Classes;

type

{ TContext }

  PContext = ^TContext;
  TContext = record
    Counter: Integer;
    Event: THandle;
    EndEvent: THandle;
  end;

{ TBaseWorkThread }

  TBaseWorkThread = class(TThread)
  protected
    procedure WaitEvent(Event: THandle; CheckTerminate: Boolean = False);
  public
    constructor Create;
  end;


{ TWorkThread }

  TWorkThread = class(TBaseWorkThread)
  private
    FContext: TContext;
  protected
    procedure Execute; override;
  end;

{ TWorkLoopThread }

  TWorkLoopThread = class(TBaseWorkThread)
  protected
    procedure Execute; override;
  end;

implementation

uses
  Windows, CallBack;

type
  ETerminate = class(Exception);

procedure CallBack(Flag: Integer; Context: NativeInt);
var
  Cntxt: PContext absolute Context;
begin
  if Flag = 1 then
  begin
    InterlockedIncrement(Cntxt.Counter);
    SetEvent(Cntxt.Event);
  end;

  if Flag = 2 then
  begin
    SetEvent(Cntxt.EndEvent);
  end;
end;

{ TBaseWorkThread }

constructor TBaseWorkThread.Create;
begin
  inherited Create(False);
end;

procedure TBaseWorkThread.WaitEvent(Event: THandle; CheckTerminate: Boolean);
begin
  while WaitForSingleObject(Event, 10) <> WAIT_OBJECT_0 do
  begin
    if CheckTerminate and Terminated then
      raise ETerminate.Create('');

    Sleep(10);
  end;
end;

{ TWorkThread }

procedure TWorkThread.Execute;
begin
  NameThreadForDebugging('WorkThread');

  try
    FContext.Counter  := 0;
    FContext.Event    := CreateEvent(nil, False, False, nil);
    FContext.EndEvent := CreateEvent(nil, False, False, nil);

    try
      try
        InvokeCallBack(CallBack, 1, NativeInt(@FContext));
        WaitEvent(FContext.Event, True);
        if FContext.Counter = 0 then
          Writeln('WaitForSingleObject error');
      finally
        CloseHandle(FContext.Event);
      end;
    finally
      InvokeCallBack(CallBack, 2, NativeInt(@FContext));
      WaitEvent(FContext.EndEvent);
      CloseHandle(FContext.EndEvent);
    end;
  except
    on E: Exception do
    begin
      if not (E is ETerminate) then
        Writeln('WorkThread error: ' + E.ClassName, ': ', E.Message);
    end;
  end;
end;

{ TWorkLoopThread }

procedure TWorkLoopThread.Execute;
var
  Context: TContext;
begin
  NameThreadForDebugging('WorkLoopThread');
  try
    while not Terminated do
    begin
      Context.Counter  := 0;
      Context.Event    := CreateEvent(nil, False, False, nil);
      Context.EndEvent := CreateEvent(nil, False, False, nil);

      try
        try
          InvokeCallBack(CallBack, 1, NativeInt(@Context));
          WaitEvent(Context.Event);
          if Context.Counter = 0 then
            Writeln('WaitForSingleObject error');
        finally
          CloseHandle(Context.Event);
        end;
      finally
        InvokeCallBack(CallBack, 2, NativeInt(@Context));
        WaitEvent(Context.EndEvent);
        CloseHandle(Context.EndEvent);
      end;
    end;
  except
    on E: Exception do
    begin
      if not (E is ETerminate) then
        Writeln('WorkLoopThread error: ' + E.ClassName, ': ', E.Message);
    end;
  end;
end;

end.

回调函数:

unit CallBack;

interface

type

  TCallBackProc   = procedure (Flag: Integer; Context: NativeInt);

procedure InitCallBacks;
procedure DoneCallBacks;
procedure InvokeCallBack(CallBack: TCallBackProc; Flag: Integer; Context: NativeInt);

implementation

uses
  SysUtils, Classes, Generics.Collections;

type

  TCallBackInfo = record
    Proc: TCallBackProc;
    Flag: Integer;
    Context: NativeInt;
  end;

  TCallBackProcTable = TThreadList<TCallBackInfo>;
  TCallBackQueue = TList<TCallBackInfo>;

{ TCallBackThread }

  TCallBackThread = class(TThread)
  private
    FCallBackTable: TCallBackProcTable;
  protected
    procedure Execute; override;
  public
    constructor Create;
    destructor  Destroy; override;
  end;

var
  Thread: TCallBackThread;

constructor TCallBackThread.Create;
begin
  FCallBackTable := TCallBackProcTable.Create;
  inherited Create(False);
end;

destructor TCallBackThread.Destroy;
begin
  FCallBackTable.Free;
  inherited;
end;

procedure TCallBackThread.Execute;
var
  Empty: Boolean;
  CallBackList: TCallBackQueue;
  CallBackInfo: TCallBackInfo;
begin
  NameThreadForDebugging('CallBack Thread');

  while not Terminated do
  begin
    Sleep(100);

    CallBackList := FCallBackTable.LockList;
    try
      if CallBackList.Count = 0 then Continue;

      CallBackInfo := CallBackList.First;
      CallBackList.Delete(0);
    finally
      FCallBackTable.UnlockList;
    end;

    //Sleep(200);
    CallBackInfo.Proc(CallBackInfo.Flag, CallBackInfo.Context);
  end;
end;

{ API }

procedure InitCallBacks;
begin
  Thread := TCallBackThread.Create;
end;

procedure DoneCallBacks;
begin
  Thread.Terminate;
  Thread.WaitFor;
  Thread.Free;
end;

procedure InvokeCallBack(CallBack: TCallBackProc; Flag: Integer; Context: NativeInt);
var
  CallBackInfo: TCallBackInfo;
begin
  CallBackInfo.Proc    := CallBack;
  CallBackInfo.Flag    := Flag;
  CallBackInfo.Context := Context;
  Thread.FCallBackTable.Add(CallBackInfo);
end;

end.

在这个应用程序中，我创建了许多用于循环处理的线程，以及许多不断创建和销毁的线程。所有线程都使用回调模拟来设置它们的事件。当应用程序检测到错误时，它会将 “WaitForSingleObject error” 写入控制台。

WorkThread.pas 中描述了使用 WaitForSingleObject() 和 SetEvent() 的线程。 CallBack.pas 中描述了一个简单的回调模拟器。 MainThread.pas 管理线程。

在这个应用中，这个bug出现的频率不高，有时候要等1个小时。但在具有许多 win handles 的实际应用程序中，bug 很快就会出现。

如果我使用简单的 bool 标志而不是事件，一切正常。我的结论是这是一个系统错误。我对吗？

PS:操作系统 - 64 位应用程序 - 32 位

更新

Remy Lebeau pointed out my mistake

我把所有的CreateEvent(nil, False, False, '')都替换成CreateEvent(nil, False, False, nil)，但是bug还是会出现。

Answer 1

您滥用了 CreateEvent()，特别是它的 lpName 参数。

参数定义为 PChar，而不是 String。将 '' 文字传递给 PChar 不会像您期望的那样为其分配一个 nil 指针。它分配一个空终止符 Char 的地址。

当您使用非 nil lpName 值调用 CreateEvent() 时，即使是 null 终止符本身，您正在创建一个命名的内核中的事件。您的线程因此在内核中共享命名的事件对象，然后您在它们上等待多次。调用 SetEvent() 将所有 打开句柄的信号状态设置为相同 内核事件对象。这就是为什么您的 WaitForSingleObject() 调用没有像您期望的那样等待 - 它们正在等待已经发出信号的事件句柄。

你需要在调用CreateEvent()时将''改为nil，这样你的事件对象就不再被命名，从而不再共享。

Delphi 自己的 TEvent 类中也存在同样的错误，直到 XE7，包括 XE7:

QC #100175: SyncObjs.TEvent invalid construction

RSP-9999: SyncObjs.TEvent invalid construction