在一个不断创建和销毁许多线程的程序中，
有时WaitForSingleObject()会返回WAIT_OBJECT_0，但未调用预期事件的SetEvent()。我试图在互联网上查找信息，但无法找到类似的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小时。但是在具有许多胜利句柄的真实应用程序中，错误很快就会发生。
如果我使用简单的布尔标志而不是事件，一切正常。 我得出结论，这是一个系统错误。我对吗？
PS：操作系统 - 64位应用 - 32位
更新
Remy Lebeau pointed out my mistake
我将所有CreateEvent(nil, False, False, '')替换为CreateEvent(nil, False, False, nil)，但仍然会发生错误。
答案 0 :(得分：9)
您滥用CreateEvent()，特别是其lpName参数。
参数定义为PChar，而不是String。将''字面值传递给PChar不会像您期望的那样为其分配nil指针。它改为指定空终止符Char的地址。
当您使用非CreateEvent() nil值（即使是空终结符）调用lpName时，您正在内核中创建命名事件。因此，您的线程在内核中共享命名的事件对象，然后您在它们上多次等待。对SetEvent()的调用会为相同内核事件对象的所有打开句柄设置信号状态。这就是为什么你的WaitForSingleObject()调用没有像你期望的那样等待 - 他们正在等待已经发出信号的事件句柄。
调用''时，您需要将nil更改为CreateEvent()，以便您的事件对象不再被命名，从而不再共享。
这个同样的错误存在于Delphi自己的TEvent类中，包括XE7：