Как реализовать сверхточный таймер?

=== Как реализовать сверхточный таймер? ===
Windows is not a real time operating system so it is not really able to reliably achieve high accuracy timing without using a device driver. The best I have been able to get is a few nanoseconds using QueryPerformanceCounter. This is the procedure I use:
var
 WaitCal: Int64;
procedure Wait(ns: Integer);
var
 Counter, Freq, WaitUntil: Int64;
begin
 if QueryPerformanceCounter(Counter) then
 begin
 QueryPerformanceFrequency(Freq);
 WaitUntil := Counter + WaitCal + (ns * (Freq div 1000000));
 while Counter < WaitUntil do
 QueryPerformanceCounter(Counter);
 end
 else
 Sleep(ns div 1000);
end;
To get improved accuracy do this a little while before using Wait()
var
 Start, Finish: Int64;
Application.ProcessMessages;
Sleep(10);
QueryPerformanceCounter(Start);
Wait(0);
QueryPerformanceCounter(Finish);
WaitCal := Start - Finish;
A trick I have found to increase the reliability of this on my computer is to call Wait like this:
Application.ProcessMessages;
Sleep(0);
DoSomething;
Wait(10);
DoSomethingElse;
Source: Взято из http://www.lmc-mediaagentur.de/dpool
ID: 00186
----
Unit Counter;
(* Written by Jin *)
{$O-,F-,S-,N-,R-,Q-}
Interface
Type
 tTimerValue = record
 Micro: Word; { Счётчик 8253/8254 }
 Counter: Longint { Счётчик BIOS }
 End;
Const
 MicroFreq = 1193181 { $1234DD }; { Частота обновления счётчика Micro (1/сек) }
 CounterFreq = MicroFreq / 65536; { Частота обновления счётчика Counter (1/сек) }
 MicroInterval = 1 / MicroFreq; { Интервал обновления счётчика Micro (сек) }
 CounterInterval = 1 / CounterFreq; { Интервал обновления счётчика Counter (сек) }
Var
 BIOSCounter: Longint absolute $0040:$006C;
{ Системный счётчик (обновляется CounterFreq раз/сек, }
{ то есть каждые CounterInterval секунд) }
Procedure InitTimer;
{ Инициализировать таймер (перевести в нужный режим работы). }
{ Эту процедуру необходимо выполнять перед использованием функций }
{ и процедур для получения значения таймера (или счётчика), если }
{ Вы в своей программе изменили режим работы таймера. В противном }
{ случае эта процедура Вам не понадобится, так как она выполняется }
{ в секции инициализации модуля (сразу после запуска программы) ! }
Procedure GetTimerValue(var Timer: tTimerValue);
{ Записать значение таймера в переменную Timer }
Function GetTimerSec: Real;
{ Получить значение таймера в секундах (с точностью до 1 мкс) }
Function GetTimerMillisec: Longint;
{ Получить значение таймера в миллисекундах }
Procedure GetTimerDifference(var Older, Newer, Result: tTimerValue);
{ Записать разницу значений Newer и Older в переменную Result }
Function GetTimerDifSec(var Older, Newer: tTimerValue): Real;
{ Получить разницу значений Newer и Older в секундах }
Function GetTimerDifMillisec(var Older, Newer: tTimerValue): Longint;
{ Получить разницу значений Newer и Older в миллисекундах }
Function ConvTimer2Sec(var Timer: tTimerValue): Real;
{ Получить количество секунд по значению переменной Timer }
Function ConvTimer2Millisec(var Timer: tTimerValue): Longint;
{ Получить количество миллисекунд по значению переменной Timer }
Procedure ConvSec2Timer(Sec: Real; var Timer: tTimerValue);
{ Преобразовать значение секунд Sec типа Real в тип tTimerValue }
Procedure ConvMillisec2Timer(Millisec: Longint; var Timer: tTimerValue);
{ Преобразовать значение миллисекунд Millisec типа Longint в тип tTimerValue }
Procedure ResetCounter;
{ Сбросить счётчик (то есть принять текущее значение таймера за ноль для }
{ процедуры GetCounterValue и функции GetCounterSec) }
Procedure GetCounterValue(var Timer: tTimerValue);
{ Записать значение счётчика в переменную Timer }
Function GetCounterSec: Real;
{ Получить значение секунд счётчика }
Function GetCounterMillisec: Longint;
{ Получить значение миллисекунд счётчика }
Procedure Delay(MS: Word);
{ Задержка MS миллисекунд (1 сек = 1000 мс) }
Procedure DelaySec(Sec: Real);
{ Задержка Sec секунд }
Procedure MDelay(N: Longint);
{ Задержка N * MicroInterval секунд (приближённо N * 0.838095813 мкс). }
{ Если Вам нужны наиболее точные короткие задержки, лучше использовать }
{ эту процедуру, так как она даёт наименьшую погрешность по сравнению }
{ с двумя предыдущими процедурами. }
Implementation
Var Now: tTimerValue;
Var Zero: tTimerValue;
Procedure InitTimer; assembler;
Asm
 mov al,34h { Режим 2 таймера 0 }
 out 43h,al
 xor al,al { 65536 циклов до IRQ }
 out 40h,al
 out 40h,al
End
Procedure GetTimerValue; assembler;
Asm
 cld
 xor ax,ax
 mov es,ax
 mov bx,46Ch { DS:BX = 0000h:046Ch = Таймер BIOS }
 cli
 mov dx,es:[bx]
 mov cx,es:[bx+2]{ CX:DX = Первое значение таймера BIOS }
 sti
 out 43h,al { Замораживаем таймер 8253/8254 }
 cli
 mov si,es:[bx]
 mov di,es:[bx+2]{ DI:SI = Второе значение таймера BIOS }
 in al,40h
 mov ah,al
 in al,40h
 sti
 xchg ah,al { AX = Таймер 8253/8254 }
 not ax { Обратный отсчёт -> Прямой отсчёт }
 cmp dx,si { Первое значение таймера BIOS равно второму значению ? }
 je @Ok { Да! Оставляем как есть (CX:DX), иначе... }
 or ax,ax { Таймер BIOS изменился после заморозки таймера 8253/8254 (между OUT и CLI) ? }
 js @Ok { Да! Оставляем как есть (CX:DX), иначе... }
 mov dx,si
 mov cx,di { CX:DX = DI:SI, если таймер BIOS изменился между STI и OUT }
@Ok:
 les di,Timer
 stosw { Low Word }
 xchg ax,dx
 stosw { Middle Word }
 xchg ax,cx
 stosw { High Word - Записаны из CX:DX:AX }
End
Function GetTimerSec;
Begin
 GetTimerValue(Now);
 GetTimerSec := ConvTimer2Sec(Now)
End;
Function GetTimerMillisec;
Begin
 GetTimerMillisec := Trunc(GetTimerSec*1000)
End;
Procedure GetTimerDifference; assembler;
Asm
 cld
 push ds
 lds si,Newer
 lodsw { Low Word }
 xchg cx,ax
 lodsw { Middle Word }
 xchg dx,ax
 lodsw { High Word }
 xchg cx,ax { Прочитаны в CX:DX:AX }
 lds si,Older
 sub ax,[si]
 sbb dx,[si+2]
 sbb cx,[si+4] { Вычитаем Older из Newer }
 les di,Result
 stosw { Low Word }
 xchg ax,dx
 stosw { Middle Word }
 xchg ax,cx
 stosw { High Word - Записано из CX:DX:AX }
 pop ds
End
Function GetTimerDifSec;
Begin
 GetTimerDifference(Older, Newer, Now);
 GetTimerDifSec := ConvTimer2Sec(Now)
End;
Function GetTimerDifMillisec;
Begin
 GetTimerDifMillisec := Trunc(GetTimerDifSec(Older, Newer)*1000)
End;
Function ConvTimer2Sec;
Begin
 ConvTimer2Sec := (Timer.Counter*65536 + Timer.Micro) / MicroFreq
End;
Function ConvTimer2Millisec;
Begin
 ConvTimer2Millisec := Trunc(ConvTimer2Sec(Timer)*1000)
End;
Procedure ConvSec2Timer;
Begin
 Timer.Counter := Trunc(Sec * CounterFreq);
 Timer.Micro := Trunc(Sec * MicroFreq) mod 65536
End;
Procedure ConvMillisec2Timer;
Begin
 Timer.Counter := Trunc(Millisec/1000 * CounterFreq);
 Timer.Micro := Trunc(Millisec/1000 * MicroFreq) mod 65536
End;
Procedure ResetCounter;
Begin
 GetTimerValue(Zero)
End;
Procedure GetCounterValue;
Begin
 GetTimerValue(Timer);
 GetTimerDifference(Zero, Timer, Timer)
End;
Function GetCounterSec;
Begin
 GetTimerValue(Now);
 GetTimerDifference(Zero, Now, Now);
 GetCounterSec := ConvTimer2Sec(Now)
End;
Function GetCounterMillisec;
Begin
 GetCounterMillisec := Trunc(GetCounterSec*1000)
End;
Procedure Delay;
Var Zero: Longint;
Begin
 If MS <= 0 then Exit;
 Zero := GetTimerMillisec;
 Repeat
 Until GetTimerMillisec-Zero >= MS
End;
Procedure DelaySec;
Var Zero: Real;
Begin
 If Sec <= 0 then Exit;
 Zero := GetTimerSec;
 Repeat
 Until GetTimerSec-Zero >= Sec
End;
Procedure MDelay;
Label Check;
Var Zero: tTimerValue;
Begin
 If N <= 0 then Exit;
 GetTimerValue(Zero);
 Check:
 GetTimerValue(Now);
 GetTimerDifference(Zero, Now, Now);
 Asm
 mov ax,word ptr Now
 mov dx,word ptr Now+2 { DX:AX - Прошедшее время }
{ mov cx,word ptr Now+4
 or cx,cx
 jnz @Exit}
 cmp dx,word ptr N+2 { Проверяем старшие слова }
 jb Check
 cmp ax,word ptr N { Проверяем младшие слова }
 jb Check
 @Exit:
 EndEnd;
Begin
 InitTimer
End.
И вот ещё программа-тестер:
Uses Counter;
Var
 Ans: Char;
 i: Longint;
 Sec: Real;
Begin
 Asm
 mov ah,0Dh
 int 21h { Сбрасываем кэш }
 mov ax,1681h
 int 2Fh { Запрещаем Windows Task Switch }
 End
 Write('Без задержки...');
 ResetCounter;
 Sec := GetCounterSec;
 WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');
 Write('1000 раз холостой цикл...');
 ResetCounter;
 For i := 1 to 1000 do ;
 Sec := GetCounterSec;
 WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');
 Write('1000 раз по 0 сек...');
 ResetCounter;
 For i := 1 to 1000 do
 DelaySec(0);
 Sec := GetCounterSec;
 WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');
 WriteLn('-------------------------------------------------');
 Write('1 раз 1 сек...');
 ResetCounter;
 DelaySec(1);
 Sec := GetCounterSec;
 WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');
 Write('1000 раз по 0.001 сек...');
 ResetCounter;
 For i := 1 to 1000 do
 DelaySec(0.001);
 Sec := GetCounterSec;
 WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');
 Write('10000 раз по 0.0001 сек...');
 ResetCounter;
 For i := 1 to 10000 do
 DelaySec(0.0001);
 Sec := GetCounterSec;
 WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');
 Write('100000 раз по 0.00001 сек...');
 ResetCounter;
 For i := 1 to 100000 do
 DelaySec(0.00001);
 Sec := GetCounterSec;
 WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');
 Write('119318 раз по 1/119318.1 сек...');
 ResetCounter;
 For i := 1 to 119318 do
 MDelay(10);
 Sec := GetCounterSec;
 WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');
 WriteLn('-------------------------------------------------');
 Write('Запускать тесты по микросекундам (м.б. очень долгими) [Y/N] ? : ');
 Asm
 @Repeat:
 xor ah,ah
 int 16h
 or al,20h
 cmp al,'y'
 je @Ok
 cmp al,'n'
 jne @Repeat
 @Ok:
 mov Ans,al
 End
 WriteLn(Ans);
 If Ans = 'y' then
 Begin
 Write('1000000 раз по 0.000001 сек...');
 ResetCounter;
 For i := 1 to 1000000 do
 DelaySec(0.000001);
 Sec := GetCounterSec;
 WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек');
 Write('1193181 раз по 1/1193181 сек...');
 ResetCounter;
 For i := 1 to 1193181 do
 MDelay(1);
 Sec := GetCounterSec;
 WriteLn(#8#8#8': прошло ', Sec: 0: 6, ' сек')
 End;
 Asm
 mov ax,1682h
 int 2Fh { Разрешаем Windows Task Switch }
 EndEnd.
Не забывайте, что погрешности, которые будет выдавать программа-тестер будут из-за того, что какое-то время тратиться на вызов процедуры, циклы и т.д. (т.к. там используются процедуры DelaySec, MDelay).... Но если вызвать ResetCounter, а через некоторое время GetCounterSec, то результат будет точным (собственно, именно так здесь и измеряются погрешности)! И можно вызывать его (GetCounterSec) ещё хоть 10000 раз! ;DКстати, запускайте тестер только в полноэкранном режиме, т.к. программа отключает многозадачность Windows, и на экране вы ничего не увидите (будет впечатление, что прога повисла). 
Source: Взято из http://forum.sources.ru
ID: 00187
----
А вот ещё один способ (работает только на Pentium или выше)....
Unit TSCDelay; (* Работает только на Pentium (и то не всегда ;) *)
{$O-,F-,G+,S-,R-}
Interface
Var
 CPUClock: Longint; { Тактовая частота процессора (гц) }
Procedure CalcCPUClock;
{ Вычислить тактовую частоту процессора и записать в переменную CPUClock. }
Procedure MDelay(N: Longint);
{ Производит задержку в N микросекунд. Задержки более 4294967296/CPUClock }
{ (на 300-м ~ 14) секунд будут работать неправильно из-за переполнения!!! }
{ Перед использованием это процедуры необходимо установить правильное }
{ значение переменной CPUClock. Это можно сделать либо вручную, либо }
{ выполнив процедуру CalcCPUClock. }
Procedure TDelay(N: Longint);
{ Производит задержку в N тактов процессора }
Implementation
Uses Dos;
Var
 SaveInt08: Pointer;
 Stage: Byte;
Procedure SpeedCounter; far; assembler; { Наш IRQ 0 }
Asm
 push ax
 push ds
 mov ax,seg @Data
 mov ds,ax
 inc Stage { Прибавляем к Stage единицу }
 mov al,20h
 out 20h,al { Посылаем сигнал "конец IRQ" }
 pop ds
 pop ax
 iret { Выходим }
End
Procedure CalcCPUClock;
Begin
 Asm
 mov ah,0Dh
 int 21h { Сбрасываем кэш }
 mov ax,1681h
 int 2Fh { Отключаем Windows Task Switch }
 in al,0A1h { Маски IRQ 8-15 }
 mov ah,al
 in al,21h { Маски IRQ 0-7 }
 push ax { Сохраняем маски }
 mov al,0FEh
 out 21h,al { Запрещаем IRQ 1-7 (нулевой нам нужен) }
 inc ax
 out 0A1h,al { Запрещаем IRQ 8-15 }
 mov al,36h
 out 43h,al { Устанавливаем нормальный режим работы таймера }
 xor al,al
 out 40h,al
 out 40h,al { 65536 циклов до IRQ 0 }
 mov Stage,0 { Готовимся к началу отсчёта }
 End
 GetIntVec(8, SaveInt08); { Сохраняем старый IRQ 0 }
 SetIntVec(8, @SpeedCounter); { Устанавливаем свой IRQ 0 }
 Asm
 @1:cmp Stage,1
 jne @1 { Цикл до первого IRQ 0 }
 db 0Fh,31h { RDTSC }
 db 66h; xchg cx,ax { Запоминаем значение счётчика }
 @2:cmp Stage,2
 jne @2 { Цикл до второго IRQ 0 }
 db 0Fh,31h { RDTSC }
 db 66h; sub ax,cx { Вычитаем из текущего значение счётчика запомненное }
 db 66h,0B9h; dd 1234DDh { mov ecx,1234DDh }
 db 66h; mul cx { Умножаем значение на 1193181 }
 db 66h,0Fh,0ACh,0D0h,10h { shrd eax,edx,16 - делим на 65536 }
 db 66h; mov word ptr CPUClock,ax { Записываем результат в CPUClock }
 pop ax
 out 21h,al { Восстанавливаем маску IRQ 0-7 }
 mov al,ah
 out 0A1h,al { Восстанавливаем маску IRQ 8-15 }
 End
 SetIntVec(8, SaveInt08); { Восстанавливаем старый IRQ 0 }
 Asm
 mov ax,1682h
 int 2Fh { Включаем Windows Task Switch }
 EndEnd;
Procedure MDelay; assembler;
Asm
 db 0Fh,31h { RDTSC }
 db 66h; push ax
 db 66h; push dx { Сохраняем счётчик в стеке }
 db 66h; mov ax,word ptr N
 db 66h; mov cx,word ptr CPUClock
 db 66h; mul cx { Умножаем N на CPUClock }
 db 66h,0B9h; dd 1000000 { mov ecx,1000000 }
 db 66h; div cx { Затем делим на 1000000 }
 db 66h; xchg si,ax { Сохраняем значение в ESI }
 db 66h; pop cx
 db 66h; pop bx { Восстанавливаем значение счётчика в ECX:EBX }
 @:db 0Fh,31h { RDTSC }
 db 66h; sub ax,bx
 db 66h; sbb dx,cx { Вычитаем из текущего счётчика ECX:EBX }
 db 66h; or dx,dx { Старшая часть разницы д.б. всегда 0, проверяем это }
 jnz @Exit { Нет - выходим! }
 db 66h; cmp ax,si { Проверяем - прошло ли столько, сколько нам надо }
 jb @ { Нет - ждём ещё }
 @Exit:
End
Procedure TDelay; assembler;
Asm
 db 0Fh,31h { RDTSC }
 db 66h; mov bx,ax
 db 66h; mov cx,dx { Сохраняем счётчик в ECX:EBX }
 @:db 0Fh,31h { RDTSC }
 db 66h; sub ax,bx
 db 66h; sbb dx,cx { Вычитаем из текущего счётчика ECX:EBX }
 db 66h; or dx,dx { Старшая часть разницы д.б. всегда 0, проверяем это }
 jnz @Exit { Нет - выходим! }
 db 66h; cmp ax,word ptr N { Проверяем - прошло ли столько, сколько нам надо }
 jb @ { Нет - ждём ещё }
 @Exit:
End
End.
И программа-тестер:
Uses TSCDelay;
Var N: Longint;
Begin
 CalcCPUClock;
 WriteLn('Тактовая частота процессора: ', CPUClock/1000000: 0: 3,' МГц');
 Write('Введите количество микросекунд (не более ', 4294967296.0/CPUClock: 0: 3, ' млн): ');
 ReadLn(N);
 Write('Задержка...');
 MDelay(N);
 WriteLn(' всё!')
End.
Source: Взято из http://forum.sources.ru
ID: 00188
----