fix(platform): монотонные часы переполнялись на Windows и были стенными на macOS

Два дефекта в источнике времени, на котором стоят абсолютные дедлайны пейсинга TX: планировщик TX_CHRONO и отправитель DUC ведут по нему сетку, и скачок часов для них означает не потерю точности, а остановку выдачи. * Windows: (V * 1000000) div QPCFreq переполняет Int64 на 9.223e12 тиках — при типовой для Windows 8+ частоте QPC 10 МГц это 10.7 суток аптайма, дальше разрыв повторяется каждые 21.35 суток (2^64/10^6). Между разрывами функция линейна, поэтому страдает не «всякая машина старше N суток», а сессия, пережившая сам момент скачка: время уходит в большой минус, NextDueUs становится недостижим, маркеры TX_CHRONO прекращаются до перезапуска, долг TCI уходит в минус, а проверки вида `FTxLastRxUs > 0` перестают срабатывать. ★Мест было ДВА: PlatformUtils.MonotonicUs и локальная ClockUs в потоке отправителя DUC (win-ветка HPSDRNetwork) — вторая пейсит ВСЕ передачи на Windows, не только TCI: WaitUntil на переполненной разности выходит сразу, пакеты уходят без выдержки, очередь опустошается пачкой и сохнет. Лечение — общая TicksToUs через частное и остаток (остаток меньше частоты, произведение не переполняется; потолок отодвинулся на сотни тысяч лет). * macOS: MonotonicUs проваливалась в общий Unix-{$ELSE} с fpgettimeofday, то есть на СТЕННЫЕ часы. Шаг NTP назад — планировщик замирает до недостижимого срока, вперёд — выдаёт пачку и начисляет фиктивный долг. Взят mach_absolute_time + mach_timebase_info: монотонен и есть на любой версии (clock_gettime на macOS только с 10.12), пересчёт тоже через частное/остаток — на Apple Silicon база 125/3. Публикация состояния часов: всё держится в ОДНОМ слове и поднимается в initialization, до старта любых потоков. Пара «значение + флаг» на слабой модели памяти (Windows ARM, Apple Silicon) позволяла читателю увидеть флаг раньше значения, получить частоту 0 и вернуть время 0 — единичный ноль в монотонных часах есть прыжок на десятки лет назад. Windows: QPCFreq, где 0 — не выбран, >0 — частота, -1 — QPC непригоден (тогда GetTickCount64, чтобы часы хотя бы шли). Darwin: MachBase = numer shl 32 or denom. Стенд, секция H: совпадение со старой формулой ниже порога, ★негативный контроль на пороге (старая даёт -922337203685 мкс, новая +922337203685), монотонность через прежний разрыв, 100 суток на частотах 10/3.579545/24/1 МГц, год при 24 МГц, и контракт «один источник на все потоки» — четыре потока, ~850 тыс. чтений, ни нулей, ни хода назад. Итого 274/274, test/cat 50/50. ★Чего стенд не покрывает: win- и darwin-ветки здесь не компилируются вовсе (кросс-RTL не установлен). Их тела проверялись вырезкой в пробную программу с подставным API — синтаксис и арифметика сходятся, живой вызов системного счётчика остаётся за прогоном на той платформе. Co-Authored-By: Claude Opus 5 <noreply@anthropic.com> Claude-Session: https://claude.ai/code/session_01Bkwwyj7xVRrqnSVEseTRfV
2026-08-25 17:27:32 +00:00 · 2026-08-24 21:17:57 +03:00
parent 867da5921e
commit edc19fa882
3 changed files with 321 additions and 7 deletions
@@ -19,7 +19,7 @@ uses
 {$ELSE}
  Sockets, BaseUnix,
 {$ENDIF}
-  HPSDRProtocol, SyncObjs, Settings, RadioBackend;
+  HPSDRProtocol, SyncObjs, Settings, RadioBackend, PlatformUtils;

 const
  DUC_TX_QUEUE_SIZE = 256;  // power of two, bounded latency on TX underrun/overrun
@@ -515,7 +515,11 @@ var
  function ClockUs: Int64;
  begin
    QueryPerformanceCounter(QPCValue);
-    Result := (QPCValue * 1000000) div QPCFreq;
+    // ★Через PlatformUtils.TicksToUs, а не (V * 1000000) div F: наивная форма
+    // переполняет Int64 на 10.7 сутках аптайма при частоте QPC 10 МГц, и
+    // WaitUntil ниже начинает выходить немедленно — пакеты DUC уходят без
+    // выдержки, очередь опустошается пачкой и дальше сохнет FIFO радио.
+    Result := TicksToUs(QPCValue, QPCFreq);
  end;

  procedure WaitUntil(DueUs: Int64);
@@ -32,6 +32,18 @@ function GetControlScale(AControl: TControl): Integer;
 // абсолютные дедлайны, и часы, способные прыгнуть от NTP, там не годятся.
 function MonotonicUs: Int64;

+// Тики счётчика → микросекунды, без переполнения. ★Наивное (Ticks * 1000000)
+// div Freq переполняет Int64, когда Ticks переваливает за 2^63/10^6 = 9.223e12:
+// при типовой для Windows 8+ частоте QPC 10 МГц это 10.7 суток аптайма, дальше
+// разрыв повторяется каждые 21.35 суток (2^64/10^6 тиков). В момент разрыва
+// время прыгает в большой минус, и код на абсолютных дедлайнах встаёт намертво:
+// планировщик TX_CHRONO перестаёт слать маркеры, пейсинг отправителя DUC
+// выпускает пакеты без выдержки. Считаем через частное и остаток: остаток
+// меньше частоты, поэтому второе слагаемое не переполняется, а первое упирается
+// в потолок Int64 через сотни тысяч лет. Функция вынесена в интерфейс, чтобы
+// стенд мог проверить её на граничных значениях там, где Windows нет.
+function TicksToUs(Ticks, Freq: Int64): Int64;
+
 // Возвращает каталог для хранения конфигурации (с завершающим разделителем).
 // macOS:   ~/Library/Application Support/ewsdr/
 // Linux:   ~/.config/ewsdr/
@@ -49,18 +61,95 @@ uses

 {$IFDEF WINDOWS}
 var
+  // ★ОДНО слово на всё состояние часов, и вот почему. Публикуется оно обычной
+  // записью, без барьера, а читают его все потоки. Пара «значение + флаг
+  // готовности» здесь недопустима: на слабой модели памяти (Windows ARM)
+  // читатель вправе увидеть выставленный флаг раньше самого значения, получить
+  // частоту 0 и вернуть время 0 — единичный НОЛЬ в монотонных часах, то есть
+  // прыжок на десятки лет назад в бухгалтерии TX. С одним словом такого
+  // расхождения не бывает: выровненная запись Int64 атомарна, а читатель
+  // снимает её РОВНО ОДИН РАЗ в локальную переменную.
+  //   0 — источник ещё не выбран;
+  //  >0 — частота QPC;
+  //  -1 — QPC непригоден, считаем по GetTickCount64 (выбор защёлкнут навсегда:
+  //       смена источника на ходу — это тот же скачок времени).
  QPCFreq: Int64 = 0;
+
+procedure InitWinClock;
+// Идемпотентна. Зовётся из initialization — то есть ДО старта потоков.
+var F: Int64;
+begin
+  if QPCFreq <> 0 then Exit;
+  if QueryPerformanceFrequency(F) and (F > 0) then
+    QPCFreq := F
+  else
+    // Счётчика нет — часы обязаны хотя бы ИДТИ: замершее время для кода на
+    // абсолютных дедлайнах означает мёртвую передачу, а не потерю точности.
+    QPCFreq := -1;
+end;
+{$ENDIF}
+
+function TicksToUs(Ticks, Freq: Int64): Int64;
+begin
+  if Freq <= 0 then Exit(0);
+  Result := (Ticks div Freq) * 1000000 + ((Ticks mod Freq) * 1000000) div Freq;
+end;
+
+{$IFDEF DARWIN}
+// ★macOS: gettimeofday — СТЕННЫЕ часы, шаг NTP или правка руками уводят их
+// вперёд и назад. Для абсолютных дедлайнов это негодный источник: назад —
+// планировщик замирает до недостижимого срока, вперёд — выдаёт пачку и
+// начисляет фиктивный долг. mach_absolute_time монотонен и есть на любой
+// версии системы (в отличие от clock_gettime, появившегося в 10.12).
+type
+  TMachTimebase = record
+    Numer: LongWord;
+    Denom: LongWord;
+  end;
+
+function mach_absolute_time: QWord; cdecl; external 'c' name 'mach_absolute_time';
+function mach_timebase_info(var Info: TMachTimebase): Integer; cdecl;
+  external 'c' name 'mach_timebase_info';
+
+var
+  // ★Тоже ОДНО слово: numer в старшей половине, denom в младшей. Раздельные
+  // numer/denom дали бы ту же гонку публикации, что и на Windows (Apple Silicon
+  // — слабая модель памяти), а делить на прочитанный ноль нельзя вовсе.
+  MachBase: Int64 = 0;
+
+procedure InitMachClock;
+// Идемпотентна. Зовётся из initialization — то есть ДО старта потоков.
+var
+  Info: TMachTimebase;
+begin
+  if MachBase <> 0 then Exit;
+  Info.Numer := 0;
+  Info.Denom := 0;
+  if (mach_timebase_info(Info) <> 0) or (Info.Denom = 0) or (Info.Numer = 0) then
+  begin
+    // Тайминг-базы нет (быть такого не должно) — считаем тики наносекундами,
+    // как на Intel, где numer = denom = 1.
+    Info.Numer := 1;
+    Info.Denom := 1;
+  end;
+  MachBase := (Int64(Info.Numer) shl 32) or Int64(Info.Denom);
+end;
 {$ENDIF}

 function MonotonicUs: Int64;
 {$IFDEF WINDOWS}
 var
-  V: Int64;
+  V, F: Int64;
 begin
-  if QPCFreq <= 0 then
-    if not QueryPerformanceFrequency(QPCFreq) then Exit(0);
+  F := QPCFreq;                 // снимок ОДНОГО слова: см. объявление
+  if F = 0 then
+  begin
+    InitWinClock;               // страховка: сюда доходит только вызов раньше
+    F := QPCFreq;               // initialization, чего в норме не бывает
+  end;
+  if F < 0 then Exit(Int64(GetTickCount64) * 1000);
  QueryPerformanceCounter(V);
-  Result := (V * 1000000) div QPCFreq;
+  Result := TicksToUs(V, F);
 end;
 {$ELSE}
  {$IFDEF LINUX}
@@ -71,12 +160,36 @@ begin
  Result := Int64(TS.tv_sec) * 1000000 + TS.tv_nsec div 1000;
 end;
  {$ELSE}
+    {$IFDEF DARWIN}
+var
+  T, Ns, MachNumer, MachDenom: QWord;
+  B: Int64;
+begin
+  B := MachBase;                // снимок ОДНОГО слова: см. объявление
+  if B = 0 then
+  begin
+    InitMachClock;              // страховка: сюда доходит только вызов раньше
+    B := MachBase;              // initialization, чего в норме не бывает
+  end;
+  MachNumer := QWord(B) shr 32;
+  MachDenom := QWord(B) and $FFFFFFFF;
+  if (MachNumer = 0) or (MachDenom = 0) then Exit(0);
+  T := mach_absolute_time;
+  // Через частное и остаток по той же причине, что и на Windows: на Apple
+  // Silicon numer/denom = 125/3, и произведение тиков на 125 растёт быстро.
+  Ns := (T div MachDenom) * MachNumer + ((T mod MachDenom) * MachNumer) div MachDenom;
+  Result := Int64(Ns div 1000);
+end;
+    {$ELSE}
 var
  TV: TTimeVal;
 begin
+  // Прочие Unix: монотонного источника под рукой нет, остаются стенные часы.
+  // ★Знать об этом обязан тот, кто ведёт абсолютные дедлайны (см. TCIServer).
  fpgettimeofday(@TV, nil);
  Result := Int64(TV.tv_sec) * 1000000 + TV.tv_usec;
 end;
+    {$ENDIF}
  {$ENDIF}
 {$ENDIF}

@@ -168,4 +281,16 @@ begin
    ForceDirectories(Result);
 end;

+// ★Часы инициализируем ЗДЕСЬ, до старта любых потоков: ленивая инициализация
+// из рабочего потока публиковала бы состояние обычной записью, а на слабой
+// модели памяти сосед вправе увидеть её частично. Одного нуля в монотонных
+// часах хватает, чтобы бухгалтерия TX получила скачок времени.
+initialization
+{$IFDEF WINDOWS}
+  InitWinClock;
+{$ENDIF}
+{$IFDEF DARWIN}
+  InitMachClock;
+{$ENDIF}
+
 end.
@@ -28,7 +28,7 @@ program tcitest;
 uses
  cthreads, Classes, SysUtils, Math, SyncObjs, Sockets, BaseUnix,
  TCIProtocol, TCIStreams, TCIServer, TCIAdapter, RadioController,
-  WsClient, WebUtils, WDSPEngine, Settings, CWMorse;
+  WsClient, WebUtils, WDSPEngine, Settings, CWMorse, PlatformUtils;

 var
  Passed, Failed: Integer;
@@ -2207,6 +2207,186 @@ begin
  end;
 end;

+type
+  // Читатель монотонных часов для проверки контракта «один источник на все
+  // потоки»: каждый поток следит за СВОЕЙ последовательностью.
+  TClockReader = class(TThread)
+  private
+    FBack:  Integer;    // сколько раз время пошло назад
+    FZero:  Integer;    // сколько раз вернулся ноль (непроинициализированный источник)
+    FReads: Integer;
+    FMs:    Integer;
+  protected
+    procedure Execute; override;
+  public
+    constructor Create(Ms: Integer);
+    property Back: Integer read FBack;
+    property Zero: Integer read FZero;
+    property Reads: Integer read FReads;
+  end;
+
+constructor TClockReader.Create(Ms: Integer);
+begin
+  FMs := Ms;
+  inherited Create(False);
+end;
+
+procedure TClockReader.Execute;
+var
+  Deadline: QWord;
+  Prev, Cur: Int64;
+begin
+  Prev := MonotonicUs;
+  Deadline := GetTickCount64 + QWord(FMs);
+  while GetTickCount64 < Deadline do
+  begin
+    Cur := MonotonicUs;
+    Inc(FReads);
+    if Cur = 0 then Inc(FZero);
+    if Cur < Prev then Inc(FBack);
+    Prev := Cur;
+  end;
+end;
+
+procedure TestMonotonicTicks;
+// Пересчёт тиков счётчика в микросекунды (PlatformUtils.TicksToUs).
+// ★Проверять это на Linux можно и нужно: сама функция платформы не знает, а
+// ветки, которые её зовут (QPC на Windows, mach на macOS), на стенде не
+// исполняются вовсе. Считаем моделью, по граничным значениям.
+// ★Чего стенд НЕ покрывает: сами ветки MonotonicUs под Windows и Darwin здесь
+// даже не компилируются (кросс-RTL не установлен). Их тела проверялись
+// отдельно — вырезанием из PlatformUtils.pas в пробную программу с подставным
+// API (QueryPerformance*/mach_*): синтаксис и арифметика сходятся, живой вызов
+// системного счётчика остаётся непроверенным до прогона на той платформе.
+const
+  US_PER_S = 1000000;
+  // Частоты, которые встречаются живьём: 10 МГц — типовая для Windows 8+ на
+  // x86, 3.579545 МГц — старые чипсеты, 24 МГц — часть ARM, 1 МГц — «круглый»
+  // случай.
+  FREQS: array[0..3] of Int64 = (10000000, 3579545, 24000000, 1000000);
+var
+  i, k: Integer;
+  F, V, Prev, Cur, Old, Want, Days: Int64;
+  Mono, Exact: Boolean;
+  Readers: array of TClockReader;
+  Total, Zeros, Backs: Integer;
+begin
+  WriteLn('H. Монотонные часы: пересчёт тиков в микросекунды');
+
+  Check('часы: секунда счётчика = 1 000 000 мкс',
+        TicksToUs(10000000, 10000000) = US_PER_S,
+        IntToStr(TicksToUs(10000000, 10000000)));
+  Check('часы: нулевая частота не роняет и не врёт временем',
+        TicksToUs(123456789, 0) = 0);
+
+  // ── Совпадение со старой формулой ТАМ, ГДЕ ТА ЕЩЁ РАБОТАЛА ──
+  // Правка не имеет права менять показания на нормальных значениях: это тот же
+  // пересчёт, только без промежуточного произведения.
+  Exact := True;
+  F := 10000000;
+  V := 0;
+  for k := 0 to 200 do
+  begin
+    Old := (V * US_PER_S) div F;          // прежняя форма, ниже порога верна
+    if TicksToUs(V, F) <> Old then Exact := False;
+    V := V + 37 * 1000 * 1000 * 1000;     // шагаем по ~час аптайма
+  end;
+  Check('часы: ниже порога переполнения показания те же, что и раньше', Exact);
+
+  // ── Порог, на котором ломалась старая форма ──
+  // 2^63 / 10^6 = 9223372036854.775 тиков; первый тик ЗА ним — 9223372036855,
+  // при 10 МГц это 10.67 суток аптайма.
+  V   := 9223372036855;                   // первый тик за порогом
+  Old := (V * US_PER_S) div F;            // ★старая форма: уже переполнилась
+  Cur := TicksToUs(V, F);
+  Days := Cur div (Int64(86400) * US_PER_S);
+  WriteLn(Format('  ..   порог: тик %d при 10 МГц = %d суток; старая форма даёт ' +
+                 '%d мкс, новая %d мкс', [V, Days, Old, Cur]));
+  Check('часы: старая форма на пороге уходила в минус (негативный контроль)',
+        Old < 0, IntToStr(Old));
+  // При 10 МГц микросекунда — это десять тиков.
+  Check('часы: новая форма на пороге считает верно',
+        (Cur > 0) and (Abs(Cur - V div 10) <= 1), IntToStr(Cur));
+
+  // ── Монотонность через разрыв старой формулы ──
+  // Ради этого всё и делалось: планировщик TX ведёт АБСОЛЮТНЫЕ дедлайны, и один
+  // скачок времени назад останавливает выдачу маркеров до перезапуска.
+  Mono := True;
+  Prev := TicksToUs(V - 1000, F);
+  for k := -999 to 1000 do
+  begin
+    Cur := TicksToUs(V + k, F);
+    if Cur < Prev then Mono := False;
+    Prev := Cur;
+  end;
+  Check('часы: через прежний разрыв время не идёт назад', Mono);
+
+  // ── Сто суток аптайма на всех живых частотах ──
+  Exact := True;
+  Mono  := True;
+  for i := 0 to High(FREQS) do
+  begin
+    F    := FREQS[i];
+    Days := 100;
+    V    := Days * 86400 * F;
+    Want := Days * 86400 * US_PER_S;
+    if Abs(TicksToUs(V, F) - Want) > 1 then Exact := False;
+    // И заодно шаг: на любой частоте время обязано расти, а не прыгать.
+    Prev := TicksToUs(V, F);
+    for k := 1 to 500 do
+    begin
+      Cur := TicksToUs(V + Int64(k) * (F div 1000), F);   // шаг 1 мс
+      if (Cur < Prev) or (Cur - Prev > 1100) then Mono := False;
+      Prev := Cur;
+    end;
+  end;
+  Check('часы: 100 суток аптайма считаются точно на всех живых частотах', Exact);
+  Check('часы: шаг 1 мс остаётся шагом 1 мс на всех живых частотах', Mono);
+
+  // Год аптайма при 24 МГц — заведомо за пределами всего, что бывает.
+  F := 24000000;
+  V := Int64(365) * 86400 * F;
+  Check('часы: год аптайма при 24 МГц не переполняется',
+        Abs(TicksToUs(V, F) - Int64(365) * 86400 * US_PER_S) <= 1,
+        IntToStr(TicksToUs(V, F)));
+
+  // Живой источник платформы обязан идти вперёд и не стоять.
+  Prev := MonotonicUs;
+  Sleep(30);
+  Cur := MonotonicUs;
+  Check('часы: живой MonotonicUs идёт вперёд',
+        (Cur > Prev) and (Cur - Prev >= 20000) and (Cur - Prev < 2000000),
+        Format('%d мкс за 30 мс сна', [Cur - Prev]));
+
+  // ── Контракт «один источник на все потоки» ──
+  // ★Ленивая инициализация часов из рабочего потока публиковала бы состояние
+  // обычной записью, и сосед на слабой модели памяти вправе увидеть её
+  // частично: результат — единичный НОЛЬ, то есть прыжок времени на десятки
+  // лет назад в бухгалтерии TX. Поэтому источник поднимается в initialization,
+  // а состояние держится в ОДНОМ слове. Здесь проверяем сам контракт: ни нулей,
+  // ни хода назад под нагрузкой из нескольких потоков.
+  // (На Linux это ветка clock_gettime, состояния у неё нет вовсе — проверка
+  // страхует от регресса, если ленивое состояние заведут и здесь.)
+  SetLength(Readers, 4);
+  for i := 0 to High(Readers) do Readers[i] := TClockReader.Create(150);
+  Total := 0;
+  Zeros := 0;
+  Backs := 0;
+  for i := 0 to High(Readers) do
+  begin
+    Readers[i].WaitFor;
+    Inc(Total, Readers[i].Reads);
+    Inc(Zeros, Readers[i].Zero);
+    Inc(Backs, Readers[i].Back);
+    Readers[i].Free;
+  end;
+  WriteLn(Format('  ..   четыре потока: %d чтений часов, нулей %d, ходов назад %d',
+                 [Total, Zeros, Backs]));
+  Check('часы: из нескольких потоков не возвращают ноль', Zeros = 0,
+        IntToStr(Zeros));
+  Check('часы: из нескольких потоков не идут назад', Backs = 0, IntToStr(Backs));
+end;
+
 procedure TestEndToEnd;
 const
  PORT  = 40098;
@@ -2657,6 +2837,11 @@ begin
  TestServer;
  TestEndToEnd;
  TestTxPacing;
+  // ★Часы идут ПОСЛЕ тяжёлых частей намеренно: они создают потоки, а брошенный
+  // TX-поток движка когда-то лишал процесс этой возможности вовсе (лечение — в
+  // WDSPEngine.Close, остановка потока вынесена до гейта FInitialized). Порядок
+  // сохраняет ту проверку живой: упадёт снова — увидим здесь.
+  TestMonotonicTicks;
  WriteLn;
  WriteLn(Format('Итого: %d проверок, провалено %d', [Passed + Failed, Failed]));
  if Failed > 0 then Halt(1);