Last time I wrote about an Active Sleep procedure that allows better blocking wait function than classic combination of “Sleep” and “Application.ProcessMessages”. I had some interesting discussions about that with my coworker and a fellow Delphi programmer (gabr). They had three valid arguments about my approach:

  1. There could be reentrancy problems if message was posted after the event was fired, but before the MsgWaitForMultipleObjects was called.
  2. There could be reentrancy problems if in internal message loop some code is called, that should not be called while wait was active.
  3. This approach is inferior to a queue of “blocking” requests that wait there to be processed.

All three arguments seemed valid, so I decided to look into them and find out what can be done about them.

I will start by 3. argument. I agree that approach with a queue is better in theory. You pool the requests in a queue, processing them one by one and in the meantime you do not process anything that should wait for those requests to finish. You can process any other code that is not bound to them. While waiting, no actual blocking is happening anywhere. It is all about structuring your code correctly.

This sound as a sound approach and it is, but it takes a lot of work to set up such a framework. Now in two situations I cannot justify such an approach (note that gabr wrote a threading library that makes this actually very simple):

  1. Your “blocking” problem is simple and isolated to that small code area.
  2. Your application is not written in a way that could easily adopt the queue approach.

It seems to me that in such cases the queue approach is overkill. But I would absolutely prefer it if you have an application that relies heavily on blocking or non-blocking actions that take place during some code execution.

Now to the other two arguments. The 1. one is not actually a problem as the study showed. If a message (action is completed) arrived after the action was started and before the MsgWaitForMultipleObjects is called, the MsgWaitForMultipleObjects will exit right away, because it has an “unflaged” message in the queue. The only possible problem here is if some code elsewhere would call PeekMessage with PM_NOREMOVE flag. This would flag the message as read and block the wait code.

Raymond Chen had a blog post about that issue some time ago.

Even if you worry about that, you still have two possible solutions to the problem:

  1. You can use an external Event passed to the ActiveSleep Function
  2. You can call MsgWaitForMultipleObjectsEx with MWMO_INPUTAVAILABLE flag.

The first would enable that the wait object is handled from outside the function and could be signaled before the MsgWaitForMultipleObject is called. The second approach will exit right away if a message if in the queue, even if it is flaged as read.

The first approach would look like this. First the action code and the action calling code.

procedure TQMLAction.Execute;
begin
  // set flags and run
  FSuccessful := False;
  FIsRunning := True;
  FStartTime := Now;
  Inc(FExecuteCount);
 
  FActionEvent := CreateEvent(nil, False, False, nil);
  // execute the basic action code
  FThread := TQMLBasicAction.Create(FActionEvent);
 
  // if wait then cycle
  if FAction.Wait then
  begin
    while FIsRunning do
    begin
      if FAction.Timeout > 0 then
       if (MilliSecondsBetween(Now, FStartTime) > (FAction.Timeout * 1000)) then
       begin
         FSuccessful := TActionThread(FThread).SuccessStatus;
         FThread := 0;
         Exit;
       end;
 
      case FAction.Timeout > 0 of
        True: ActiveSleep(FAction.Timeout * 1000, QS_SENDMESSAGE, FActionEvent);
        False: ActiveSleep(INFINITE, QS_SENDMESSAGE, FActionEvent);
      end;
    end;
  end;
end;
procedure TQMLBasicAction.Execute;
begin
  // process the action event code
  // set the event as finished
  SetEvent(ActionEvent);
end;

An then the modified ActiveSleep procedure.

procedure TQMLAction.ActiveSleep(const Timeout, WakeMask: Cardinal; const Handle: Cardinal);
var
  Msg: TMsg;
  Result: DWORD;
begin
  Result := MsgWaitForMultipleObjects(1,              { 1 handle to wait on }
                                      Handle,         { the handle }
                                      False,          { wake on any event }
                                      Timeout ,       { wait with timeout }
                                      WakeMask        { wake on sendmessage }
                                      );
 
  if Result <> WAIT_TIMEOUT then
  begin
    while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
    begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
    end;
  end;
end;

The second approach is actually wery similar to the original:

procedure TQMLAction.ActiveSleep(const Timeout, WakeMask: Cardinal);
var
  Msg: TMsg;
  Handle: THandle;
  Result: DWORD;
begin
  Handle := OpenThread(SYNCHRONIZE, False, GetCurrentThreadID);
 
  Result := MsgWaitForMultipleObjectsEx(1,              { 1 handle to wait on }
                                        Handle,         { the handle }
                                        False,          { wake on any event }
                                        Timeout ,       { wait with timeout }
                                        WakeMask        { wake on sendmessage }
                                        MWMO_INPUTAVAILABLE { wake if message in queue});
 
  if Result <> WAIT_TIMEOUT then
  begin
    while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
    begin
      TranslateMessage(Msg);
      DispatchMessage(Msg);
    end;
  end;
end;

So we have dealt with the two problems at hand. Now the problem number 2. Yes potentially this could cause problems but only if the code is poorly written and we are not aware of the workings of such a wait loop. As long as you know what you are doing, you should be fine.

I have showed that such an approach is completely reasonable in certain situations. And if nothing else, I see so many poorly written “Sleep” / “Application.ProcessMessages” loops that this post should help at least in some of those cases.