Thread Posting messages to Main UI Thread are blocked/removed

Question

My problem is that if a thread Posting messages rapidly to the main UI thread and if I update the UI at that time, sometimes the main message queue get stuck (I have no better words to describe this).

Here is the 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_MESSAGE, 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, 0, @ThreadProc, nil, 0, ThreadId);
end;

I do realize that the worker thread loop is very busy. I thought that since the thread is Posting messages to the main UI thread, it (the main UI thread) has the chance to process it's messages while receiving other messages from the worker thread.
The problem escalates as I increase the counter.

Problems:
I never see Label1 being updated unless I add Label1.Update; and the main UI is blocked.
TH_PARAM_ACTION never reaches 100000 (in my case) - randomly above 90000.
TH_PARAM_FINISH never gets to the message queue.
Obviously the CPU usage is very high.

Questions:
What is the correct way to handle this situation? Are messages posted from the worker thread being removed from the message queue (if yes, then why)?
Is Sleep(1) in the loop is really the cure to this problem? if yes then why 1? (0 does not)

---

OK. Thanks to @Sertac and @LU I now realize that the message queue has a limit, and now checking for result from PostMessage with ERROR_NOT_ENOUGH_QUOTA.but, still the main UI is NOT responsive!

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, TH_MESSAGE, TH_PARAM_ACTION, 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, TH_MESSAGE, TH_PARAM_FINISH, GetCurrentThreadID);
  OutputDebugString('Thread Finish OK!'); // <- I see this
  EndThread(0);
end;

---

Just for reference here is the original code I was inspecting:
Delphi threading by example

This example searches text in files (5 threads simultaneously). Obviously when you make a task like that, you must see all the matching results (in a ListView for example).

Problem was that if I searched in meany files, and the search string was short (like "a") - there were meany matches found. the busy loop while FileStream.Read(Ch,1)= 1 do was posting messages rapidly (TH_FOUND) with the match and flooding the message queue.

Messages where in fact not getting to the message queue. as @Sertac mentioned "a message queue has a limit of 10000 by default".

From MSDN PostMessage

There is a limit of 10,000 posted messages per message queue. This limit should be sufficiently large. If your application exceeds the limit, it should be redesigned to avoid consuming so many system resources. To adjust this limit, modify the following registry key (USERPostMessageLimit)

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

Answer 1

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

If you absolutely need every single message to be handled by the main thread you'll need to maintain your own queue. And you'll likely need to throttle the thread that adds to the queue.

Your Sleep(1) will throttle, but in a very crude way. Perhaps it will throttle too much, perhaps not enough. In general you'd need to be more precise about throttling. Typically you'd throttle adaptively by keeping track of the size of the queue. If you can avoid throttling do so. It's complex, hard to implement well, and hurts performance.

The call Sleep(0) will yield if there's another thread ready to run. Otherwise Sleep(0) has no effect. From the documentation

A value of zero causes the thread to relinquish the remainder of its time slice to any other thread that is ready to run. If there are no other threads ready to run, the function returns immediately, and the thread continues execution.

On the other hand, if all you need to do is report status in your GUI then you should avoid a queue altogether. Don't post messages from the thread to the main thread. Simply run a GUI update timer in your main thread and have the main thread ask the workers for their current status.

Applying that idea to your code results in this:

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, TH_MESSAGE, TH_PARAM_FINISH, 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, 0, @ThreadProc, nil, 0, ThreadId);
  CloseHandle(ThreadHandle);
  Timer1.Enabled := True;
end;