Delphi TMonitor.Wait multi-threading problem - multithreading

Question

We have run into this multi-threading problem in our backend services:
In a multi-threading Windows service app, with 30+ threads, problem in SysUtils.EventCache arise. The problem is that NewWaitObj function sometimes return NIL instead of Event object. This function is used in TMonitor sync methods Wait. TMonitor.Wait stops working when it get NIL for event object. That affects many VCL and RTL thread sync source code and it cause different side problems in multi-threading apps, for example TThreadedQueue.PopItem doesnt wait for new item to arrive in Queue and returns immediately with timeout result.
Problem occurs in NewWaitObj function:
function NewWaitObj: Pointer;
var
EventItem: PEventItemHolder;
begin
EventItem := Pop(EventCache);
if EventItem <> nil then
begin
Result := EventItem.Event;
EventItem.Event := nil;
Push(EventItemHolders, EventItem);
end else
Result := NewSyncWaitObj;
ResetSyncWaitObj(Result);
end;
Looks like Pop function is not well protected in heavy multi-threaded app and at some number of concurrent threads it starts to return one and the same EventItem instance to two (or more) threads. Then race conditions are happening in NewWaitObj:
One thread takes EventItem.Event and return it as Result and zero it with NIL, the racing parallel thread is getting the same EventItem.Event but it is already cleared by first thread.
That cause one of racing threads to return valid Event handle and the other(s) racing threads return NIL.
TMonitor.Wait function doesnt work, because it get NIL as Event handle.
TThreadedQueue.PopItem doesnt wait, other sync methods also doesnt work correctly.
For some reason thread sync in Pop method doesnt work when app have many concurrent threads:
function Pop(var Stack: PEventItemHolder): PEventItemHolder;
begin
repeat
Result := Stack;
if Result = nil then
Exit;
until AtomicCmpExchange(Pointer(Stack), Result.Next, Result) = Result;
end;
In test app on 60 test threads problem arise in about 10-20 secs, with 30 threads its much harder to happens, usually 5-10 mins are needed. Once problem occurs - it never stop until restart of App. In test app after thread sync get broken - about one of each 5 operations with EventCache return NIL. Looks like something get broken in AtomicCmpExchange, I've checked the generated code - it's just one CMPXCHG instruction and few more to setup registers. I am not quite sure what cause the problem - can one thread get intervention from other thread for example while it setups registers to call CMPXCHG or after the call while it process the results?
Trying to understand what cause the problem, so I can find best workaround. For now I am planning to replace original NewWaitObj with my own, which will just call the original version till it return valid object. This problem occurs constantly in our dev, test and prod environments, for real middle-ware services on production servers it's needed few hours (sometimes couple of days) for problem to arise, after that only restart fix the problem.
Test app can be downloaded from issue in Embarcadero JIRA: https://quality.embarcadero.com/browse/RSP-31154
EDIT: TestApp: https://quality.embarcadero.com/secure/attachment/31605/EventCacheBug.zip
Example Delphi source code:
unit FormMainEventCacheBugU;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Math, Vcl.StdCtrls;
const
MaxProducers = 60;
type
TFormEventCacheBug = class(TForm)
BtnMaxProducers: TButton;
BtnRemoveProducer: TButton;
BtnAddProducer: TButton;
procedure BtnMaxProducersClick(Sender: TObject);
procedure BtnRemoveProducerClick(Sender: TObject);
procedure BtnAddProducerClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TEventEater = class(TThread)
private
SleepTime: Integer;
SMsg, EMsg, NMsg: PChar;
procedure EatEvent;
protected
procedure Execute; override;
public
constructor Create;
end;
var
FormEventCacheBug: TFormEventCacheBug;
Producers: array[1..MaxProducers] of TThread;
ProdCount: Integer;
implementation
{$R *.dfm}
procedure AddProducer;
begin
if ProdCount < MaxProducers then
begin
Inc(ProdCount);
Producers[ProdCount] := TEventEater.Create;
Producers[ProdCount].FreeOnTerminate := True;
end;
end;
procedure RemoveProducer;
begin
if ProdCount > 0 then
begin
Producers[ProdCount].Terminate;
Dec(ProdCount);
end;
end;
{ TEventEater }
constructor TEventEater.Create;
begin
inherited Create(False);
SleepTime := RandomRange(1, 3);
end;
procedure TEventEater.EatEvent;
var
EventHandle: Pointer;
begin
//OutputDebugString(SMsg);
EventHandle := System.MonitorSupport.NewWaitObject;
try
if EventHandle = nil then
OutputDebugString('NIL');
Sleep(SleepTime);
finally
if EventHandle <> nil then
System.MonitorSupport.FreeWaitObject(EventHandle);
// OutputDebugString(EMsg);
end;
end;
procedure TEventEater.Execute;
begin
SMsg := PChar('S:' + GetCurrentThreadId.ToString);
EMsg := PChar('E:' + GetCurrentThreadId.ToString);
NMsg := PChar('NIL:' + GetCurrentThreadId.ToString);
while not Terminated do
begin
EatEvent;
Sleep(SleepTime);
end;
end;
procedure TFormEventCacheBug.BtnAddProducerClick(Sender: TObject);
begin
AddProducer;
end;
procedure TFormEventCacheBug.BtnRemoveProducerClick(Sender: TObject);
begin
RemoveProducer;
end;
procedure TFormEventCacheBug.BtnMaxProducersClick(Sender: TObject);
var
i: Integer;
begin
for i := ProdCount + 1 to MaxProducers do
AddProducer;
end;
end.
Thanks for any ideas,

Answer 1

#MiroslavPenchev, thank you for the post!
Working in XE2 and had similar issue.
Delphi 10.4.1 got TMonitor ABA problem solved using the linked list head with a counter and 128-bit Compare Exchange.
Unfortunately this is not an easy option for XE2.
Again, thanks to your suggestion to override some of MonitorSupport methods calling original ones.
The following is the solution that I'm using. It is not 100% perfect as involves locking, but for less concurrent environment it at least makes system stable and free from 100% CPU issue.
var
MonitorSupportFix: TMonitorSupport;
OldMonitorSupport: PMonitorSupport;
NewWaitObjCS: TCriticalSection;
function NewWaitObjFix: Pointer;
begin
if Assigned(NewWaitObjCS) then
NewWaitObjCS.Enter;
try
Result := OldMonitorSupport.NewWaitObject;
finally
if Assigned(NewWaitObjCS) then
NewWaitObjCS.Leave;
end;
end;
procedure FreeWaitObjFix(WaitObject: Pointer);
begin
if Assigned(NewWaitObjCS) then
NewWaitObjCS.Enter;
try
OldMonitorSupport.FreeWaitObject(WaitObject);
finally
if Assigned(NewWaitObjCS) then
NewWaitObjCS.Leave;
end;
end;
procedure InitMonitorSupportFix;
begin
OldMonitorSupport := System.MonitorSupport;
MonitorSupportFix := OldMonitorSupport^;
MonitorSupportFix.NewWaitObject := NewWaitObjFix;
MonitorSupportFix.FreeWaitObject := FreeWaitObjFix;
System.MonitorSupport := #MonitorSupportFix;
end;
initialization
NewWaitObjCS := TCriticalSection.Create;
InitMonitorSupportFix;
finalization
FreeAndNil(NewWaitObjCS);
end.