Я задавал этот вопрос раньше немного по-другому. В тот момент я понятия не имел, в чем именно проблема, пока я не начал экспериментировать с ответами, которые я получил с форума (спасибо всем). Проблема заключается в следующем:
Для генерации 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 *, но я удалил все ссылки на это. Это не имеет значения.
Кто-нибудь знает, что я делаю не так?