From edc19fa8825a33d9f8069b97c2ff3ea552470ec2 Mon Sep 17 00:00:00 2001 From: Vladimir Date: Mon, 24 Aug 2026 21:17:57 +0300 Subject: [PATCH] =?UTF-8?q?fix(platform):=20=D0=BC=D0=BE=D0=BD=D0=BE=D1=82?= =?UTF-8?q?=D0=BE=D0=BD=D0=BD=D1=8B=D0=B5=20=D1=87=D0=B0=D1=81=D1=8B=20?= =?UTF-8?q?=D0=BF=D0=B5=D1=80=D0=B5=D0=BF=D0=BE=D0=BB=D0=BD=D1=8F=D0=BB?= =?UTF-8?q?=D0=B8=D1=81=D1=8C=20=D0=BD=D0=B0=20Windows=20=D0=B8=20=D0=B1?= =?UTF-8?q?=D1=8B=D0=BB=D0=B8=20=D1=81=D1=82=D0=B5=D0=BD=D0=BD=D1=8B=D0=BC?= =?UTF-8?q?=D0=B8=20=D0=BD=D0=B0=20macOS?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Два дефекта в источнике времени, на котором стоят абсолютные дедлайны пейсинга 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 Claude-Session: https://claude.ai/code/session_01Bkwwyj7xVRrqnSVEseTRfV --- HPSDRNetwork.pas | 8 +- PlatformUtils.pas | 133 +++++++++++++++++++++++++++++- test/tci/tcitest.pas | 187 ++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 321 insertions(+), 7 deletions(-) diff --git a/HPSDRNetwork.pas b/HPSDRNetwork.pas index 1197059..4b4f7f0 100644 --- a/HPSDRNetwork.pas +++ b/HPSDRNetwork.pas @@ -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); diff --git a/PlatformUtils.pas b/PlatformUtils.pas index 192a5ba..f396aa3 100644 --- a/PlatformUtils.pas +++ b/PlatformUtils.pas @@ -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. diff --git a/test/tci/tcitest.pas b/test/tci/tcitest.pas index 44aaf42..6d5a36b 100644 --- a/test/tci/tcitest.pas +++ b/test/tci/tcitest.pas @@ -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);