问题
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!
- 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.
- By calling ProcessMessages you are introducing a delay of unknown length. You don't know how long it will take for ProcessMessages to return.
- 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;
来源：https://stackoverflow.com/questions/7778558/how-to-prevent-hints-interrupting-a-timer