TThreadedQueue не в состоянии нескольких потребителей

Question

Попытка использовать 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 update 4 было объявлено исправление для TMonitor, которое исправило бы проблемы в TThreadedQueue. Мои тесты до сих пор не могут воспроизвести никаких ошибок в TThreadedQueue. Протестировано один поток производителей / несколько потребителей, когда очередь пуста и заполнена. Также проверено несколько производителей / нескольких потребителей. Я изменил темы чтения и записи писателя от 1 до 100 без каких-либо затруднений. Но, зная историю, я смею другим ломать TMonitor.

Answer 1

Что ж, трудно быть уверенным без большого количества тестирования, но, похоже, это ошибка как в TThreadedQueue, так и в TMonitor.В любом случае это в RTL, а не в вашем коде.Вы должны подать его в виде отчета о контроле качества и использовать приведенный выше пример в качестве кода «как воспроизвести».

Answer 2

Я рекомендую вам использовать OmniThreadLibrary http://www.thedelphigeek.com/search/label/OmniThreadLibrary при работе с потоками, параллелизмом и т. Д. Primoz проделал очень хорошую работу, и на сайте вы найдете много полезной документации.

Answer 3

Ваш пример, кажется, работает нормально под XE2, но если мы заполняем вашу очередь, он завершается неудачно с AV на PushItem. (Протестировано в XE2 Update1)

Чтобы воспроизвести, просто увеличьте создание задачи со 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;

Answer 4

Я искал класс TThreadedQueue, но, похоже, его нет в моем D2009. Я не собираюсь убивать себя из-за этого - поддержка потоков Delphi всегда была ошибочной .. ошибкой ... 'неоптимальной', и я подозреваю, что 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.

Answer 5

Я не думаю, что TThreadedQueue должен поддерживать несколько потребителей.Это FIFO, согласно файлу справки.У меня сложилось впечатление, что одна нить толкает, а другая (только одна!) Трещит.