2

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

我编写了一个发生此错误的小型测试应用程序。

事件测试.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.

回调.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句柄的实际应用程序中，bug很快就会出现。

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

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

更新

Remy Lebeau 指出了我的错误

我全部替换CreateEvent(nil, False, False, '')为CreateEvent(nil, False, False, nil)，但仍然出现错误。

4

1 回答 1

9

你在滥用CreateEvent()，特别是它的lpName参数。

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

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

您需要在调用时更改''为，以便您的事件对象不再命名，因此不再共享。nilCreateEvent()

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

QC #100175：SyncObjs.TEvent 构造无效

RSP-9999：SyncObjs.TEvent 构造无效

于 2015-04-06T17:19:37.880 回答