WaitForSingleObject return WAIT_OBJECT_0 but SetEvent was not called

Question

In a program that constantly creates and destroys many threads, sometimes WaitForSingleObject() returns WAIT_OBJECT_0, but SetEvent() for an expected event was not called. I tried to find information on the Internet, but can't find a similar WaitForSingleObject() bug.

I have written a small test application in which this bug occurs.

EventsTest.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.

MainThread.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.

WorkThread.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.

CallBack.pas:

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.

In this application, I create many threads for loop handling, and many threads which constantly create and destroy. All threads are using callback emulation to set their events. When the application detects the bug, it writes "WaitForSingleObject error" to the console.

The threads which are using WaitForSingleObject() and SetEvent() are described in WorkThread.pas. In CallBack.pas is described a simple callback emulator. And MainThread.pas manages the threads.

In this application, the bug occurs infrequently, and sometimes I have to wait 1 hour. But in a real application with many win handles, bug occurs quickly.

If I use simple boolean flags instead of events, everything works fine. I conclude that it is a system bug. Am I right?

PS: OS - 64bit app - 32bit

update

Remy Lebeau pointed out my mistake

I replace all CreateEvent(nil, False, False, '') to CreateEvent(nil, False, False, nil), but bug still occurs.

Answer 1

You are misusing CreateEvent(), specifically its lpName parameter.

The parameter is defined as a PChar, not a String. Passing a '' literal to a PChar DOES NOT assign a nil pointer to it, like you are expecting. It assigns the address of a null terminator Char instead.

When you call CreateEvent() with a non-nil lpName value, even a null terminator by itself, you are creating a named event in the kernel. Your threads are thus sharing named event objects in the kernel, and then you are waiting multiple times on them. A call to SetEvent() sets the signaled state for all open handles to the same kernel event object. That is why your WaitForSingleObject() calls are not waiting like you are expecting - they are waiting on event handles that have already been signaled.

You need to change '' to nil when calling CreateEvent(), so that your event objects are no longer named, and thus no longer shared.

This very same bug exists in Delphi's own TEvent class up to, and including, XE7:

QC #100175: SyncObjs.TEvent invalid construction

RSP-9999: SyncObjs.TEvent invalid construction