Multithreading – prevents / removes threads from publishing messages to the main UI thread

My problem is that if a thread quickly publishes messages to the main UI thread, and if I update the UI at that time, sometimes the main message queue will get stuck (I don't have a better word to describe this)

This is a simplified Repro Code:

const
  TH_MESSAGE = WM_USER + 1; // Thread message
  TH_PARAM_ACTION = 1;
  TH_PARAM_FINISH = 2;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    ThreadHandle: Integer;
    procedure ThreadMessage(var Message: TMessage); message TH_MESSAGE;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function ThreadProc(Parameter: Pointer): Integer;
var
  ReceiverWnd: HWND;
  I: Integer;
  Counter: Integer;
begin
  Result := 0;
  ReceiverWnd := Form1.Handle;
  Counter := 100000;
  for I := 1 to Counter do
  begin
    PostMessage(ReceiverWnd,TH_MESSAGE,TH_PARAM_ACTION,I);
    //Sleep(1); // <- is this the cure?
  end;
  PostMessage(ReceiverWnd,TH_PARAM_FINISH,GetCurrentThreadID);
  OutputDebugString('Thread Finish OK!'); // <- I see this
  EndThread(0);
end;

procedure TForm1.ThreadMessage(var Message: TMessage);
begin
  case Message.WParam of
    TH_PARAM_ACTION:
      begin
        Label1.Caption := 'Action' + IntToStr(Message.LParam);
        //Label1.Update;
      end;
     TH_PARAM_FINISH:
       begin
         OutputDebugString('ThreadMessage Finish'); // <- Dose not see this
         Button1.Enabled := True;
         CloseHandle(ThreadHandle);
       end;
  end;    
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ThreadId: LongWord;
begin
  Button1.Enabled := False;
  ThreadId := 1;
  ThreadHandle := BeginThread(nil,@ThreadProc,nil,ThreadId);
end;

I do realize that the worker loop is very busy I think because the thread publishes messages to the main UI thread, it (the main UI thread) has the opportunity to process its messages when it receives other messages from the worker thread When I add counters, the problem escalates

Question: unless I add label1 Update, otherwise I never see label1 updating; And the main UI is blocked TH_ PARAM_ Action will never reach 100000 (in my case) – more than 90000 at random TH_ PARAM_ Finish will never enter the message queue Obviously, CPU utilization is very high

Question: what is the correct way to deal with this situation? Are messages published from worker threads removed from the message queue (if so, why)? Sleep in sleep (1) can you really solve this problem? If so, why 1? (0 no)

OK Thanks to @ sertac and @ Lu, I now realize that there is a limitation on message queuing. Now I use error_ NOT_ ENOUGH_ Quote to check the results of PostMessage However, the main UI is still not responding!

function ThreadProc(Parameter: Pointer): Integer;
var
  ReceiverWnd: HWND;
  I: Integer;
  Counter: Integer;
  LastError: Integer;
  ReturnValue,Retry: Boolean;
begin
  Result := 0;
  ReceiverWnd := Form1.Handle;
  Counter := 100000;
  for I := 1 to Counter do
  begin
    repeat
      ReturnValue := PostMessage(ReceiverWnd,I);
      LastError := GetLastError;
      Retry := (not ReturnValue) and (LastError = ERROR_NOT_ENOUGH_QUOTA);
      if Retry then
      begin
        Sleep(100); // Sleep(1) is not enoght!!!
      end;
    until not Retry;
  end;
  PostMessage(ReceiverWnd,GetCurrentThreadID);
  OutputDebugString('Thread Finish OK!'); // <- I see this
  EndThread(0);
end;

For reference only, this is the original code I am checking: Delphi threading by example

This example searches for text in a file (5 threads at the same time) Obviously, when you create such a task, you must see all matching results (for example, in listview)

The problem is, if I search in the Meany file and the search string is short (such as "a") – I will find a lot of matches When FileStream When read (CH, 1) = 1, the busy loop does quickly publish the message (th_found) and match and fill the message queue

No messages actually reach the message queue As @ sertac mentioned, "by default, the message queue is limited to 10000."

From MSDN PostMessage

As others have said, this code / pattern should be redesigned

Solution

You are flooding the message queue at a rate greater than the rate at which messages are processed Eventually the queue became full

If you absolutely need the main thread to process each message, you need to maintain your own queue And you may need to limit the threads added to the queue

Your sleep (1) will step on the accelerator, but it will be very rough Maybe it will kill too much, maybe not enough In general, you need to understand throttling more accurately In general, you can limit adaptively by tracking the size of the queue If you can avoid saving money, do so It is complex, difficult to implement well, and will damage performance

If another thread is ready to run, a call to sleep (0) will result Otherwise sleep (0) is invalid From document

On the other hand, if all you need to do is report status in the GUI, you should completely avoid a queue Do not publish messages from the thread to the main thread Just run the GUI update timer in the main thread and let the main thread ask the staff about the current status

Applying this idea to your code produces the following results:

const
  TH_MESSAGE = WM_USER + 1; // Thread message
  TH_PARAM_FINISH = 2;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    procedure ThreadMessage(var Message: TMessage); message TH_MESSAGE;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

var
  Count: Integer;

function ThreadProc(Parameter: Pointer): Integer;
var
  ReceiverWnd: HWND;
  I: Integer;
begin
  Result := 0;
  ReceiverWnd := Form1.Handle;
  for I := 1 to high(Integer) do
  begin
    Count := I;
  end;
  PostMessage(ReceiverWnd,GetCurrentThreadID);
end;

procedure TForm1.ThreadMessage(var Message: TMessage);
begin
  case Message.WParam of
  TH_PARAM_FINISH:
    begin
      Button1.Enabled := True;
      Timer1.Enabled := False;
    end;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Label1.Caption := 'Action' + IntToStr(Count);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ThreadId: LongWord;
  ThreadHandle: THandle;
begin
  Count := -1;
  Button1.Enabled := False;
  ThreadHandle := BeginThread(nil,ThreadId);
  CloseHandle(ThreadHandle);
  Timer1.Enabled := True;
end;