multithreading - WaitForSingleObject は WAIT_OBJECT_0 を返しますが、SetEvent は呼び出されませんでした

Question

常に多くのスレッドを作成および破棄するプログラムでは、がWaitForSingleObject()返されることがありますが、予期されたイベントが呼び出されませんでした。インターネットで情報を探してみましたが、同様のバグは見つかりませんでした。WAIT_OBJECT_0SetEvent()WaitForSingleObject()

このバグが発生する小さなテストアプリケーションを作成しました。

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.

このアプリケーションでは、ループ処理用に多くのスレッドを作成し、常に作成および破棄する多くのスレッドを作成します。すべてのスレッドは、コールバックエミュレーションを使用してイベントを設定します。"WaitForSingleObject error"アプリケーションがバグを検出すると、コンソールに書き込みます。

WaitForSingleObject()とを使用しているスレッドは、SetEvent()で説明されていWorkThread.pasます。ではCallBack.pas、簡単なコールバックエミュレータについて説明します。そしてMainThread.pas、スレッドを管理します。

このアプリケーションでは、まれにバグが発生し、1 時間待たなければならないこともあります。しかし、多くの win ハンドルを持つ実際のアプリケーションでは、すぐにバグが発生します。

イベントの代わりに単純なブール値フラグを使用すると、すべて正常に動作します。システムのバグであると結論付けています。私は正しいですか？

PS: OS - 64 ビットアプリ - 32 ビット

アップデート

Remy Lebeau は私の間違いを指摘しました

CreateEvent(nil, False, False, '')すべてをに置き換えますがCreateEvent(nil, False, False, nil)、まだバグが発生します。

multithreading - WaitForSingleObject は WAIT_OBJECT_0 を返しますが、SetEvent は呼び出されませんでした

1 に答える 1

Related

Reference