Попытка использовать TThreadedQueue (Generics.Collections) в единой схеме множественного потребления. (Delphi XE). Идея состоит в том, чтобы вставлять объекты в очередь и пропускать несколько рабочих потоков в очередь.
Однако он работает не так, как ожидалось. Когда два или более рабочих потока вызывают PopItem, нарушения доступа выводятся из TThreadedQueue.
Если вызов PopItem сериализуется с критическим разделом, все в порядке.
Конечно, TThreadedQueue должен иметь возможность обрабатывать несколько пользователей, так что я что-то упускаю или это чистая ошибка в TThreadedQueue?
Вот простой пример для получения ошибки.
program TestThreadedQueue;
{$APPTYPE CONSOLE}
uses
// FastMM4 in '..\..\..\FastMM4\FastMM4.pas',
Windows,
Messages,
Classes,
SysUtils,
SyncObjs,
Generics.Collections;
type TThreadTaskMsg =
class(TObject)
private
threadID : integer;
threadMsg : string;
public
Constructor Create( ID : integer; const msg : string);
end;
type TThreadReader =
class(TThread)
private
fPopQueue : TThreadedQueue<TObject>;
fSync : TCriticalSection;
fMsg : TThreadTaskMsg;
fException : Exception;
procedure DoSync;
procedure DoHandleException;
public
Constructor Create( popQueue : TThreadedQueue<TObject>;
sync : TCriticalSection);
procedure Execute; override;
end;
Constructor TThreadReader.Create( popQueue : TThreadedQueue<TObject>;
sync : TCriticalSection);
begin
fPopQueue:= popQueue;
fMsg:= nil;
fSync:= sync;
Self.FreeOnTerminate:= FALSE;
fException:= nil;
Inherited Create( FALSE);
end;
procedure TThreadReader.DoSync ;
begin
WriteLn(fMsg.threadMsg + ' ' + IntToStr(fMsg.threadId));
end;
procedure TThreadReader.DoHandleException;
begin
WriteLn('Exception ->' + fException.Message);
end;
procedure TThreadReader.Execute;
var signal : TWaitResult;
begin
NameThreadForDebugging('QueuePop worker');
while not Terminated do
begin
try
{- Calling PopItem can return empty without waittime !? Let other threads in by sleeping. }
Sleep(20);
{- Serializing calls to PopItem works }
if Assigned(fSync) then fSync.Enter;
try
signal:= fPopQueue.PopItem( TObject(fMsg));
finally
if Assigned(fSync) then fSync.Release;
end;
if (signal = wrSignaled) then
begin
try
if Assigned(fMsg) then
begin
fMsg.threadMsg:= '<Thread id :' +IntToStr( Self.threadId) + '>';
fMsg.Free; // We are just dumping the message in this test
//Synchronize( Self.DoSync);
//PostMessage( fParentForm.Handle,WM_TestQueue_Message,Cardinal(fMsg),0);
end;
except
on E:Exception do begin
end;
end;
end;
except
FException:= Exception(ExceptObject);
try
if not (FException is EAbort) then
begin
{Synchronize(} DoHandleException; //);
end;
finally
FException:= nil;
end;
end;
end;
end;
Constructor TThreadTaskMsg.Create( ID : Integer; Const msg : string);
begin
Inherited Create;
threadID:= ID;
threadMsg:= msg;
end;
var
fSync : TCriticalSection;
fThreadQueue : TThreadedQueue<TObject>;
fReaderArr : array[1..4] of TThreadReader;
i : integer;
begin
try
IsMultiThread:= TRUE;
fSync:= TCriticalSection.Create;
fThreadQueue:= TThreadedQueue<TObject>.Create(1024,1,100);
try
{- Calling without fSync throws exceptions when two or more threads calls PopItem
at the same time }
WriteLn('Creating worker threads ...');
for i:= 1 to 4 do fReaderArr[i]:= TThreadReader.Create( fThreadQueue,Nil);
{- Calling with fSync works ! }
//for i:= 1 to 4 do fReaderArr[i]:= TThreadReader.Create( fThreadQueue,fSync);
WriteLn('Init done. Pushing items ...');
for i:= 1 to 100 do fThreadQueue.PushItem( TThreadTaskMsg.Create( i,''));
ReadLn;
finally
for i:= 1 to 4 do fReaderArr[i].Free;
fThreadQueue.Free;
fSync.Free;
end;
except
on E: Exception do
begin
Writeln(E.ClassName, ': ', E.Message);
ReadLn;
end;
end;
end.
Обновить. Ошибка в TMonitor, которая вызвала сбой TThreadedQueue, исправлена в Delphi XE2.
Обновление 2. Вышеупомянутый тест подчеркнул очередь в пустом состоянии. Дарьян Миллер обнаружил, что подчеркивание очереди в полном состоянии, все же может воспроизвести ошибку в XE2. Ошибка снова находится в TMonitor. См. Его ответ ниже для получения дополнительной информации. А также ссылку на QC101114.
Обновление 3:
С обновлением Delphi-XE2 4 было объявлено исправление для TMonitor
, которое устранило бы проблемы в TThreadedQueue
. Мои тесты до сих пор больше не могут воспроизвести какие-либо ошибки в TThreadedQueue
.
Протестированные потоки одного производителя/нескольких потребителей, когда очередь пуста и заполнена.
Также проверено несколько производителей/несколько потребителей. Я менял нити считывателя и писательские потоки от 1 до 100 без каких-либо сбоев. Но, зная историю, я осмеливаюсь, чтобы другие нарушили TMonitor
.
Ну, трудно быть уверенным без большого тестирования, но, похоже, это ошибка, либо в TThreadedQueue, либо в TMonitor. В любом случае это в RTL, а не в вашем коде. Вы должны указать это как отчет о контроле качества и использовать свой пример выше как код "как воспроизвести".
Я рекомендую вам использовать OmniThreadLibrary http://www.thedelphigeek.com/search/label/OmniThreadLibrary при работе с потоками, parallelism и т.д. Примоц сделал очень хорошую работу, и на сайте вы найдете много полезной документации.
Ваш пример, похоже, отлично работает под XE2, но если мы заполняем вашу очередь, он не работает с AV на PushItem. (Протестировано под обновлением XE21)
Чтобы воспроизвести, просто увеличьте создание своей задачи с 100 до 1100 (ваша глубина очереди была установлена на 1024)
for i:= 1 to 1100 do fThreadQueue.PushItem( TThreadTaskMsg.Create( i,''));
Это умирает для меня каждый раз в Windows 7. Я изначально пробовал постоянный толчок к стресс-тестированию, и он не прошел в петле 30... затем в цикле 16... затем в 65 так на разных интервалах, но он последовательно не удалось в какой-то момент.
iLoop := 0;
while iLoop < 1000 do
begin
Inc(iLoop);
WriteLn('Loop: ' + IntToStr(iLoop));
for i:= 1 to 100 do fThreadQueue.PushItem( TThreadTaskMsg.Create( i,''));
end;
Я искал класс TThreadedQueue, но, похоже, не имел его в своем D2009. Я не собираюсь убивать себя над этим - поддержка потока Delphi всегда была ошибкой.. errm... "неоптимальным", и я подозреваю, что TThreadedQueue ничем не отличается:)
Зачем использовать дженерики для объектов P-C (Продюсер/Потребитель)? Простой потомок TObjectQueue прекрасно справится с этим - на протяжении десятилетий он отлично работает с несколькими производителями/потребителями:
unit MinimalSemaphorePCqueue;
{ Absolutely minimal P-C queue based on TobjectQueue and a semaphore.
The semaphore count reflects the queue count
'push' will always succeed unless memory runs out, then you're stuft anyway.
'pop' has a timeout parameter as well as the address of where any received
object is to be put.
'pop' returns immediately with 'true' if there is an object on the queue
available for it.
'pop' blocks the caller if the queue is empty and the timeout is not 0.
'pop' returns false if the timeout is exceeded before an object is available
from the queue.
'pop' returns true if an object is available from the queue before the timeout
is exceeded.
If multiple threads have called 'pop' and are blocked because the queue is
empty, a single 'push' will make only one of the waiting threads ready.
Methods to push/pop from the queue
A 'semaHandle' property that can be used in a 'waitForMultipleObjects' call.
When the handle is signaled, the 'peek' method will retrieve the queued object.
}
interface
uses
Windows, Messages, SysUtils, Classes,syncObjs,contnrs;
type
pObject=^Tobject;
TsemaphoreMailbox=class(TobjectQueue)
private
countSema:Thandle;
protected
access:TcriticalSection;
public
property semaHandle:Thandle read countSema;
constructor create; virtual;
procedure push(aObject:Tobject); virtual;
function pop(pResObject:pObject;timeout:DWORD):boolean; virtual;
function peek(pResObject:pObject):boolean; virtual;
destructor destroy; override;
end;
implementation
{ TsemaphoreMailbox }
constructor TsemaphoreMailbox.create;
begin
{$IFDEF D2009}
inherited Create;
{$ELSE}
inherited create;
{$ENDIF}
access:=TcriticalSection.create;
countSema:=createSemaphore(nil,0,maxInt,nil);
end;
destructor TsemaphoreMailbox.destroy;
begin
access.free;
closeHandle(countSema);
inherited;
end;
function TsemaphoreMailbox.pop(pResObject: pObject;
timeout: DWORD): boolean;
// dequeues an object, if one is available on the queue. If the queue is empty,
// the caller is blocked until either an object is pushed on or the timeout
// period expires
begin // wait for a unit from the semaphore
result:=(WAIT_OBJECT_0=waitForSingleObject(countSema,timeout));
if result then // if a unit was supplied before the timeout,
begin
access.acquire;
try
pResObject^:=inherited pop; // get an object from the queue
finally
access.release;
end;
end;
end;
procedure TsemaphoreMailbox.push(aObject: Tobject);
// pushes an object onto the queue. If threads are waiting in a 'pop' call,
// one of them is made ready.
begin
access.acquire;
try
inherited push(aObject); // shove the object onto the queue
finally
access.release;
end;
releaseSemaphore(countSema,1,nil); // release one unit to semaphore
end;
function TsemaphoreMailbox.peek(pResObject: pObject): boolean;
begin
access.acquire;
try
result:=(count>0);
if result then pResObject^:=inherited pop; // get an object from the queue
finally
access.release;
end;
end;
end.
Я не думаю, что TThreadedQueue должен поддерживать несколько потребителей. Это FIFO, в соответствии с файлом справки. У меня создалось впечатление, что одна нить нажата, а другая (только одна!) Выскакивает.