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

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;

Взято из https://www.lmc-mediaagentur.de/dpool

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, и на экране вы ничего не увидите (будет впечатление, что прога повисла).

Автор: 7jin

Взято из https://forum.sources.ru

А вот ещё один способ (работает только на 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.

Автор: 7jin

Взято из https://forum.sources.ru