How to prevent hints interrupting a timer

问题:

I asked this question before in a slightly different way. At that moment I had no idea what exactly the problem was until I started to experiment with the answers I got from the forum (thanks all). The problem is this:

For MIDI generating I want a good timer. I now have four but they all get interrupted by a simple hint. I can start applications, perform heavy computations, whatever. The timer functions with no sweat. One hint generates an audible delay. I tried all 4 timers and they basically show the same behavior. Some of them run in a thread with highest priority.

The code of one timer looks like this. I can add others, but that is not the point I think. It appears that there is something intrinsic in either Delphi or Windows that takes higher priority than a Timecritical thread.

unit Timer_Looping;

  interface

  uses Windows, MMSystem, Messages, SysUtils, Classes, Graphics, Controls, Forms,
       Dialogs, Timer_Custom;

  type
     TTask = class (TThread)
     private
        FEnabled: boolean;
        FInterval: cardinal;
        FOnTimer: TNotifyEvent;

        procedure Yield;

     public
        constructor Create;
        destructor Destroy; override;
        procedure Execute; override;

        property Enabled: boolean read FEnabled write FEnabled;
        property Interval: cardinal read FInterval write FInterval;
        property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
     end; // Class: TWork //

     TLoopingTimer = class (TBaseTimer)
     protected
        FTask: TTask;

        procedure SetEnabled (value: boolean); override;
        procedure SetInterval (value: cardinal); override;
        procedure SetOnTimer (Task: TNotifyEvent); override;

        procedure StartTimer;
        procedure StopTimer;

     public
        constructor Create;
        destructor Destroy; override;
     end; // Class: TLooping_Timer //

  implementation

  {*******************************************************************
  *                                                                  *
  * Class TTask                                                      *
  *                                                                  *
  ********************************************************************}

  constructor TTask.Create;
  begin
     inherited Create (False);

     Self.Priority := tpTimeCritical;
  end; // Create //

  {$WARN SYMBOL_DEPRECATED OFF}
  destructor TTask.Destroy;
  begin
     Terminate;                 // terminate execute loop
     if Suspended then Resume;  // Resume the Task when waiting
     WaitFor;                   // Wait until the thread is terminated
  end; // Destroy //

  // Return control to another thread, ProcessMessages without the disadvantages
  procedure TTask.Yield;
  begin
     if Win32MajorVersion >= 6  // Vista, 2008, 7?
        then asm pause; end     // Most efficient
        else SwitchToThread;    // Else: don't use ProcessMessages or Sleep(0)
  end; // yield //

  // Execute loop, calls the callback and suspends. The timer callback
  // resumes the timer
  procedure TTask.Execute;
  var freq, time, limit: Int64;
      ms_interval: Int64;       // Interval in cycles
  begin
     QueryPerformanceFrequency (freq);
     try
        Suspend;

  // Just loop until Terminate is set
        while not Terminated do
        begin
           ms_interval := Interval * freq div 1000;

  // Loop between Enabled and Disabled
           while not Terminated and Enabled do
           begin
              QueryPerformanceCounter (time);
              limit := time + ms_interval;
              if Assigned (OnTimer) then OnTimer (Self);

  // Wait by cycling idly thru cycles. QueryPerformanceCounter is used for precision.
  // When using GetTickCount deviations of over 10ms may occur.
              while time < limit do
              begin
                 yield;
                 QueryPerformanceCounter (time);
              end; // while
           end; // while
           if not Terminated then Suspend;
        end; // while
     except
        Terminate;
     end; // try
  end; // Execute //

  {$WARN SYMBOL_DEPRECATED ON}

  {*******************************************************************
  *                                                                  *
  * Class TLooping_Timer                                             *
  *                                                                  *
  ********************************************************************}

  constructor TLoopingTimer.Create;
  begin
     inherited Create;

     FTask := TTask.Create;
     FTimerName := 'Looping';
  end; // Create //

  // Stop the timer and exit the Execute loop
  Destructor TLoopingTimer.Destroy;
  begin
     Enabled := False;          // stop timer when running
     FTask.Free;

     inherited Destroy;
  end; // Destroy //

  {$WARN SYMBOL_DEPRECATED OFF}
  procedure TLoopingTimer.StartTimer;
  begin
     FTask.Enabled := True;
     FTask.Resume;
  end; // StartBeat //
  {$WARN SYMBOL_DEPRECATED ON}

  procedure TLoopingTimer.StopTimer;
  begin
     FTask.FEnabled := False;
  end; // PauseBeat //

  procedure TLoopingTimer.SetOnTimer (Task: TNotifyEvent);
  begin
     inherited SetOnTimer (Task);

     FTask.OnTimer := Task;
  end; // SetOnTimer //

  // When true, startbeat is called, else stopbeat
  procedure TLoopingTimer.SetEnabled (value: boolean);
  begin
     FEnabled := value;
     if FEnabled
        then StartTimer
        else StopTimer;
  end; // set_enabled //

  procedure TLoopingTimer.SetInterval (value: cardinal);
  begin
     FInterval := value;
     FTask.Interval := Interval;
  end; // SetInterval //

  end. // Unit: MSC_Threaded_Timer //      
  =====================Base class=========================

  unit Timer_Custom;

  interface

  uses
    Windows, MMSystem, Messages, SysUtils, Classes, Graphics, Controls, Forms,
    Dialogs;

  type
    TCallBack = procedure (uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD);

    ETimer = class (Exception);

  {$M+}
     TBaseTimer = class (TObject)
     protected
        FTimerName: string;     // Name of the timer
        FEnabled: boolean;      // True= timer is running, False = not
        FInterval: Cardinal;      // Interval of timer in ms
        FResolution: Cardinal;    // Resolution of timer in ms
        FOnTimer: TNotifyEvent; // What to do when the hour (ms) strikes

        procedure SetEnabled (value: boolean); virtual;
        procedure SetInterval (value: Cardinal); virtual;
        procedure SetResolution (value: Cardinal); virtual;
        procedure SetOnTimer (Task: TNotifyEvent); virtual;

     public
        constructor Create; overload;

     published
        property TimerName: string read FTimerName;
        property Enabled: boolean read FEnabled write SetEnabled;
        property Interval: Cardinal read FInterval write SetInterval;
        property Resolution: Cardinal read FResolution write SetResolution;
        property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
     end; // Class: HiResTimer //

  implementation

  constructor TBaseTimer.Create;
  begin
     inherited Create;

     FEnabled    := False;
     FInterval   := 500;
     Fresolution := 10;
  end; // Create //

  procedure TBaseTimer.SetEnabled (value: boolean);
  begin
     FEnabled := value;
  end; // SetEnabled //

  procedure TBaseTimer.SetInterval (value: Cardinal);
  begin
     FInterval := value;
  end; // SetInterval //

  procedure TBaseTimer.SetResolution (value: Cardinal);
  begin
     FResolution := value;
  end; // SetResolution //

  procedure TBaseTimer.SetOnTimer (Task: TNotifyEvent);
  begin
     FOnTimer := Task;
  end; // SetOnTimer //

  end. // Unit: MSC_Timer_Custom //

I cannot duplicate this behavior in a new program. It exists very audibly in my MIDI player which is too big to list here. I did have some Application.Hint* settings but I have delete all references to this. This made no difference.

Anybody any idea what I do wrong?

回答1:

You are calling Application.ProcessMessages from a background thread. Don't do that!

1. When you do this, you are causing Windows messages to be processed in a non-main thread. VCL doesn't expect that and this can cause various problems.
2. By calling ProcessMessages you are introducing a delay of unknown length. You don't know how long it will take for ProcessMessages to return.
3. There's no need to process messages in the background thread. If you have nothing to do, call Sleep(0) or SwitchToThread.

Re 3: You can use something like this:

procedure Yield;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
    asm pause; end
  else
    Sleep(0);
end;