Как предотвратить подсказки, прерывающие таймер

Я задавал этот вопрос раньше немного по-другому. В тот момент я понятия не имел, в чем именно проблема, пока я не начал экспериментировать с ответами, которые я получил с форума (спасибо всем). Проблема заключается в следующем:

Для генерации MIDI я хочу хороший таймер. Теперь у меня их четыре, но все они прерываются простым намеком. Я могу запускать приложения, выполнять сложные вычисления, что угодно. Таймер работает без пота. Один намек генерирует звуковую задержку. Я перепробовал все 4 таймера, и они в основном показывают одинаковое поведение. Некоторые из них выполняются в потоке с наивысшим приоритетом.

Код одного таймера выглядит следующим образом. Я могу добавить других, но я не об этом думаю. Похоже, что в Delphi или Windows есть что-то присущее, которое имеет более высокий приоритет, чем поток Timecritical.

блок 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 //

Я не могу дублировать это поведение в новой программе. Он очень хорошо слышен в моем MIDI-плеере, который слишком велик, чтобы перечислять его здесь. У меня были некоторые настройки Application.Hint *, но я удалил все ссылки на это. Это не имеет значения.

Кто-нибудь знает, что я делаю не так?

delphi,timer,hints,

0

Ответов: 1


Вы вызываете Application.ProcessMessages из фонового потока. Не делай этого!

  1. Когда вы делаете это, вы заставляете сообщения Windows обрабатываться в неосновной ветке. VCL не ожидает этого, и это может вызвать различные проблемы.
  2. Вызывая ProcessMessages, вы вводите задержку неизвестной длины. Вы не знаете, сколько времени потребуется для возврата ProcessMessages.
  3. Там нет необходимости обрабатывать сообщения в фоновом потоке. Если вам нечего делать, вызовите Sleep (0) или SwitchToThread.

Re 3: Вы можете использовать что-то вроде этого:

procedure Yield;
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
    asm pause; end
  else
    Sleep(0);
end;
Дельфы, таймер, подсказки,
Похожие вопросы
Яндекс.Метрика