engineering/lumbda
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
lumbda/quantum/mod-inv-by-dialog-gcd.lsp
russell@unturf.com 1665893321
factory + quantum + sweep-doctrine: AGPLv3 share-back from foxhop ecdsa 
29 new files publish factory infra (V2 autoscaler with live VRAM
sampling + EWMA peak tracking, HUGE solo-dispatch, two-tier DLQ/rDLQ
classifier + retry), general quantum circuit primitives (Cuccaro
ripple-carry adder, Clifford gate library, Clifford tableau simulator,
mod-arith family, dialog GCD reversible inverse, Karatsuba multiplier,
Solinas fast reduction), and a TCRAUDT reducer harness. Originally
developed in ~/git/www.foxhop.net/ecdsa/ for secp256k1 attack-surface
research; published upstream as obligated by AGPLv3.

Parametrization contract at factory/CONTRACT.md. Consumers export
LUMBDA_REPO_DIR + LUMBDA_QUEUE_DIR + LUMBDA_BACKEND_CMD + LUMBDA_EMITTER_CMD
then exec factory scripts. No fork-and-modify; single source of truth
upstream.

Integration tests gate 7 V2 defect classes that wedged a live factory
on 2026-06-12 (skewed-demand starve, zero-floor reservation,
multi-tier greedy, +-25%% damping, cold-start ramp, DLQ surge halve,
post-damp CPU ceiling) + 28 DLQ classifier cases (auto-retry vs
escalate partition) + bash -n syntax lint across every script.

GPU backend stays in consumer trees; rationale in
factory/GPU-BACKEND-NOTE.md. Bend wire protocol + gpu-worker.lsp
already upstream at examples/cuda-fanout/.

make factory-lint                bash -n on every factory/*.sh
make test-integration            V2 reducer + DLQ classifier + syntax gate
make sweep-doctrine              TCRAUDT reducer gate (serial)
make sweep-doctrine-parallel     xargs -P fan-out

Verified on neoblanka: factory-lint 12 scripts PASS; test-integration
14 V2 cases + 28 DLQ classifier cases + 12 syntax cases all PASS.
2026-06-14 10:37:35 -04:00

1714 lines
76 KiB
Text
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; mod-inv-by-dialog-gcd.lsp — Phase B sweep-005: DIALOG_GCD lever.
;;;
;;; Ports HEAD's DIALOG_GCD production wiring
;;; (`configure_ecdsafail_submission_route` at
;;; `~/git/ecdsafail-challenge/src/point_add/mod.rs:31052-31257`) onto
;;; our Bernstein-Yang / Kaliski substrate. See dialog-gcd-design.md
;;; for which HEAD knobs map vs which are HEAD-substrate-specific.
;;;
;;; Three actionable HEAD levers ship here:
;;;
;;; (D1) Smooth linear width envelope per step. HEAD's
;;; `dialog_gcd_tobitvector_active_width`
;;; (mod.rs:24452-24459) replaces our coarse step-function
;;; `mib-uv-width` with a monotone-decreasing formula:
;;;
;;; ideal = N - step * SLOPE + MARGIN
;;; rounded = 2 * ceiling(max(ideal, 1) / 2)
;;; width = clamp(rounded, 1, N)
;;;
;;; At every iter (not only the late half) u/v ops run at the
;;; truncated width. HEAD's production tuning at n=256:
;;; SLOPE = 0.711, MARGIN = 26.
;;;
;;; (D2) Truncated comparator window. HEAD's
;;; `dialog_gcd_cmp_gt_truncated_into_width` (mod.rs:24319)
;;; compares only the top COMPARE_BITS slice of u/v. Sound
;;; because by D1 the high bits above active_width are |0>;
;;; comparing only the top comparator-bits of the active
;;; window is value-exact on the verifier support. HEAD's
;;; production: COMPARE_BITS = 56 at n=256.
;;;
;;; (D3) ACTIVE_ITERATIONS truncation. HEAD's
;;; `dialog_gcd_active_iterations` (mod.rs:24243-24248) caps
;;; the forward sweep at fewer than 2n iters. The verifier-
;;; reachable support converges before 2n; rare overflow is
;;; caught by the Fiat-Shamir reroll machinery. HEAD's
;;; production: 395 at n=256. We do NOT have a reroll
;;; machinery — we VERIFY correctness on every tested input;
;;; cap is set conservatively per-width.
;;;
;;; HEAD knobs that DO NOT map onto our substrate (no-op here):
;;;
;;; DIALOG_GCD_HOST_GATED — needs HEAD's `dialog_log`
;;; register (we have no equivalent)
;;; DIALOG_GCD_APPLY_WINDOW_BLOCKS — applies to HEAD's apply-phase
;;; only (we have no apply-phase)
;;; DIALOG_GCD_BODY_HOST_CIN — phase tracking primitive needed
;;; (pattern 4, not yet shipped)
;;; DIALOG_GCD_FUSED_BRANCH_BITS — HEAD's control-flow shape
;;; diverges from ours
;;;
;;; HEAD knobs landed in v2 (this file, sweep-006):
;;;
;;; DIALOG_GCD_LATE_BORROW_UV_HIGH — borrow u[active..active+uv-w] as
;;; the masking ancilla for ctrl-cuccaro-sub!/add!. Premise:
;;; bits u[uv-w..n+1] are |0> by our width-truncation envelope. We
;;; alias them as the mask scratch via offset-aware ccx-mask +
;;; cuccaro-sub-offset! / cuccaro-add-offset!, computing the mask
;;; in-place on u's high zero slice and uncomputing after. Peak
;;; qubits drop by uv-w on every iteration where the borrow
;;; engages (uv-w + uv-w <= n+1). Engagement gate:
;;; 2 * uv-w <= n+1
;;; HEAD ref: dialog_gcd_pick_borrow_slice (mod.rs:24699-24712),
;;; dialog_gcd_pick_runway_safe_borrow_slice (mod.rs:26328-26354),
;;; production wire at mod.rs:31227.
;;;
;;; DIALOG_GCD_ODD_U_LOWBIT_FASTPATH — skip lane 0 of the cswap +
;;; ctrl-cuccaro-sub!/add! body. Premise: u stays odd across
;;; every Kaliski iter (binary-GCD invariant; p is prime so
;;; initial u=p is odd; v_w-=u when both odd produces even v_w
;;; which gets shifted right; the swap controlled by a_f preserves
;;; u-odd because a_f = (f AND NOT u[0]) is zero whenever u is
;;; odd, so the cswap on lane 0 never fires). Under that
;;; invariant, the lane-0 mask compute collapses to cx(ctrl,
;;; v_w[0]) (a_f's branch never engages on lane 0 because cswap
;;; never swapped it) and the body adder can start at bit 1. HEAD
;;; ref: dialog_gcd_controlled_sub_selected lane-0 skip at
;;; mod.rs:24747-24758, ditto add at mod.rs:24831-24841, cswap
;;; skip at mod.rs:24944, production wire at mod.rs:31256.
;;;
;;; On HEAD this fastpath co-tunes with the Fiat-Shamir reroll;
;;; our substrate verifies every input, so we GATE-test soundness
;;; at circuit build by classically tracing u[0] across every
;;; iteration and erroring if u ever lands on even.
;;;
;;; ── Sign / correction handling ──────────────────────────────────
;;;
;;; classical-kaliski-trace runs the SAME classical Kaliski loop body
;;; as the quantum circuit, parameterized by the iteration count. When
;;; we cap iters at *dgcd-active-iters* we MUST recompute K-correct and
;;; the trace at the SAME capped count, else the forward & backward
;;; sweeps disagree and free! trips on dirty registers.
;;;
;;; Soundness gate: for each input a we verify
;;;
;;; classical-kaliski-r-final(a, p, iters-cap, n+1) * K = a^{-1} mod p
;;;
;;; at circuit-build time. If the cap is too aggressive for some a, K
;;; would have to differ per-a, which our 1-K-fits-all wiring can't
;;; support. We detect this and ERROR, NOT silently drop.
;;;
;;; All ancillae return to |0> by classical-replay backward sweep on
;;; the capped trace (mirrors mod-inv-by-refined!'s R1).
;;; ── *field-prime* convention ─────────────────────────────────────
;;;
;;; Dialog-GCD primitives are field-prime agnostic: classical Kaliski
;;; trace consumes p as integer arg, never reads *field-prime* directly.
;;; Consumers binding *field-prime* upstream-style still need to pass p
;;; through Kaliski entry points (mod-inv-by-dialog-gcd! &c). Width
;;; derives from caller's n+1 arg or (bit-length p). See quantum/README.md.
(load "quantum/gates.lsp")
(load "quantum/adder.lsp")
(load "quantum/mod-arith.lsp")
(load "quantum/mod-inv-by.lsp")
;;; ── knob flags ────────────────────────────────────────────────────
;;; *mod-inv-by-dialog-gcd* — main dispatcher.
;;;
;;; When non-#f, mod-inv-by! routes through mod-inv-by-dialog-gcd!.
;;; Default #f so existing sweeps reproduce byte-for-byte.
(define *mod-inv-by-dialog-gcd* #f)
;;; *dgcd-width-margin* — HEAD's DIALOG_GCD_WIDTH_MARGIN.
;;;
;;; Added to the ideal width per step. Default 37 = HEAD's pre-tuning
;;; baseline (mod.rs:24438). HEAD's production tightens to 26.
(define *dgcd-width-margin* 37)
;;; *dgcd-width-slope-x1000* — HEAD's DIALOG_GCD_WIDTH_SLOPE_X1000.
;;;
;;; Per-step shrink rate × 1000 (so an integer knob). Default 708 ~=
;;; 0.5 * 1.415 (HEAD's baseline at mod.rs:24449). HEAD's production:
;;; 711.
(define *dgcd-width-slope-x1000* 708)
;;; *dgcd-active-iters* — HEAD's DIALOG_GCD_ACTIVE_ITERATIONS.
;;;
;;; Number of Kaliski iterations. #f = 2n (textbook). Integer = capped.
;;; HEAD's production: 395 at n=256 (vs textbook 512).
(define *dgcd-active-iters* #f)
;;; *dgcd-compare-bits* — HEAD's DIALOG_GCD_COMPARE_BITS.
;;;
;;; Truncated comparator window (HEAD's `cmp_gt_truncated_into_width`).
;;; #f = full active width. Integer = top `dgcd-compare-bits` of u/v.
;;; HEAD's production: 56 at n=256.
(define *dgcd-compare-bits* #f)
;;; *dgcd-apply-clean-compare-bits* — HEAD's CLEAN_COMPARE_BITS lever
;;; (config.rs:406 dialog_gcd_apply_clean_compare_bits). Separate
;;; compare-bits for the apply-phase "clean" comparator path
;;; (dialog/mod.rs:1173-1206 dialog_gcd_clean_truncated_underflow).
;;; HEAD's a66b042 frontier sets CLEAN_COMPARE_BITS=20 — sweep-026 §2
;;; identified this as load-bearing for the 1309q route's score
;;; advantage (alongside HOSTED comparator). Distinct from the main
;;; *dgcd-compare-bits* which gates the body-phase comparator.
;;;
;;; #f = use *dgcd-compare-bits* fallback (HEAD's None branch).
;;; Integer = override with this width specifically for the apply-phase
;;; clean-comparator dispatch. AUDIT §9 lever row 358.
(define *dgcd-apply-clean-compare-bits* #f)
(define (dgcd-apply-clean-compare-bits-for-step step)
;; HEAD dialog_gcd_apply_clean_compare_bits with global override.
;; Returns the effective compare-bits for the apply-phase clean
;; comparator at `step`. Falls back to *dgcd-compare-bits* when
;; *dgcd-apply-clean-compare-bits* is #f.
(or *dgcd-apply-clean-compare-bits* *dgcd-compare-bits* 56))
;;; ── HEAD apply-phase fused measured-uncompute lever family ─────────
;;;
;;; HEAD's dialog/config.rs:146-181 + 183-195 defines 6 default-OFF
;;; levers that replace specific CCX uncomputes inside the apply-phase
;;; fused double_y / halve_y emitters with Gidney measurement (HMR +
;;; classically-conditioned CZ). 0 Toffoli for each replaced uncompute,
;;; phase-exact precisely because each control ancilla deterministically
;;; equals its set-expression at the HMR moment so the HMR's `q·rng`
;;; phase is cancelled by the cz_if's `(q-expr)·rng`.
;;;
;;; Closes AUDIT §9 row 373-374. All flags default #f (HEAD default-OFF
;;; matches lumbda byte-identity convention). Wiring into the apply-
;;; phase emit path is a follow-on sweep once dialog_gcd_fused_double_y
;;; + dialog_gcd_fused_halve_y are themselves ported (currently ABSENT
;;; per AUDIT §11 note).
;; hclear: uncompute `h = a & b` (apply-phase fused double_y/halve_y).
;; HEAD config.rs:146.
(define *dgcd-fused-hclear-measured* #f)
;; dclear: uncompute `d = ovf1 & s2` (apply-phase fused double_y).
;; Forward only -- in halve_y the matching `d` clear reads y[1]
;; after csub overwrite, so set-controls are no longer live.
;; HEAD config.rs:163.
(define *dgcd-fused-dclear-measured* #f)
;; ovfclear: uncompute ovf1 / ovf2 cleanup ancillae using known mux
;; / AND expressions (apply-phase fused double_y). HEAD config.rs:172.
(define *dgcd-fused-ovfclear-measured* #f)
;; halve_edclear: uncompute `e` and `d` in fused halve_y cleanup.
;; HEAD config.rs:179.
(define *dgcd-fused-halve-edclear-measured* #f)
;; apply-final-windowed-fast-blocks: Option<usize>; #f = disabled,
;; integer >= 2 = block count. HEAD config.rs:183.
(define *dgcd-apply-final-windowed-fast-blocks* #f)
;; apply-final-topclean-bits: usize; 0 = disabled. HEAD config.rs:190.
(define *dgcd-apply-final-topclean-bits* 0)
;; apply-final-lowq: bool; HEAD config.rs:134 (dialog_gcd_apply_final
;; _lowq_enabled). Lowq variant for the final apply step.
(define *dgcd-apply-final-lowq* #f)
;;; ── HEAD apply-chunked-f lever family ─────────────────────────────
;;;
;;; HEAD dialog/config.rs:71-131 defines 9 levers tuning the apply-
;;; phase chunked-f path. Closes AUDIT §9 rows 370-371. All default
;;; #f in lumbda. HEAD defaults reuse_cin_zero + fuse_boundary_clears
;;; ON; lumbda preserves byte-identity by defaulting them OFF.
(define *dgcd-apply-chunked-f-blocks* #f)
(define *dgcd-apply-chunked-f-cut* #f)
(define *dgcd-apply-chunked-f-cut2* #f)
(define *dgcd-apply-chunked-f-cut3* #f)
(define *dgcd-apply-chunked-f-cut4* #f)
(define *dgcd-apply-chunked-f-custom4* #f)
(define *dgcd-apply-chunked-f-custom5* #f)
(define *dgcd-apply-chunked-f-reuse-cin-zero* #f)
(define *dgcd-apply-chunked-f-fuse-boundary-clears* #f)
;;; ── apply-boundary-split lever ─────────────────────────────────────
;;;
;;; HEAD dialog/config.rs:190 (apply_boundary_split). Closes AUDIT §9
;;; row 375 third option; the other two siblings (conditional_replay
;;; + replay_swap_host) PORTED earlier.
(define *dgcd-apply-boundary-split* 0)
;;; ── HEAD raw-tier lever family ─────────────────────────────────────
;;;
;;; HEAD dialog/config.rs:43-316. Closes AUDIT §9 rows 360-369 + 373-374.
;;; 19 default-OFF flag declarations covering raw-tier dispatch (tobitvector,
;;; ipmul, quotient, apply, pa-stop). Substrate wiring lives downstream:
;;; HEAD reads these via env vars in dialog/mod.rs's raw-path routers
;;; (round763 packer, ipmul block emit, quotient driver, apply phase
;;; truncated-clean variant). Lumbda byte-identity convention: all #f
;;; means current emit unchanged; cells that match HEAD's tuned route set
;;; the relevant flag #t.
;; raw-apply-{direct,materialized}-special-add: HEAD config.rs:43,50.
;; Selects DIRECT vs MATERIALIZED special-add variants in raw-apply.
(define *dgcd-raw-apply-direct-special-add* #f)
(define *dgcd-raw-apply-materialized-special-add* #f)
;; raw-apply-reverse-{fast-sub,materialized-special-sub}: HEAD config.rs:57,64.
;; Mirrors above for the reverse-direction apply sub-path.
(define *dgcd-raw-apply-reverse-fast-sub* #f)
(define *dgcd-raw-apply-reverse-materialized-special-sub* #f)
;; reverse-branch-conditional-replay: HEAD config.rs:204.
(define *dgcd-reverse-branch-conditional-replay* #f)
;; raw-tobitvector levers: HEAD config.rs:233,240,247.
(define *dgcd-raw-tobitvector-materialized-sub* #f)
(define *dgcd-raw-tobitvector-variable-width* #f)
(define *dgcd-raw-tobitvector-borrow-future-log-carries* #f)
;; raw-ipmul / raw-quotient levers: HEAD config.rs:255-281.
;; raw-quotient-terminal-reuse falls back to raw-ipmul-terminal-reuse
;; in HEAD when its env var is unset; lumbda mirrors with a #f
;; sentinel meaning "fall through" — callers check raw-ipmul flag
;; if quotient flag is #f.
(define *dgcd-raw-ipmul-terminal-reuse* #f)
(define *dgcd-raw-ipmul-clear-p-residual* #f)
(define *dgcd-raw-quotient-terminal-reuse* #f)
(define *dgcd-raw-quotient-keep-terminal-u* #f)
;; kcorr-route-via-primitive (sweep blackops 2026-06-11): when #t,
;; the host file's K-correction release/reacquire window routes
;; through dgcd-{release,reacquire}-terminal-vec! instead of raw
;; free!/alloc! calls. Today, runway=#f, byte-identical to raw
;; free!/alloc! sequence. Forward-compat with runway-aware partial
;; release (sweep-runway-layout follow-up). Default #f preserves
;; byte-identity for kcorrw0 + night17 champions.
(define *dgcd-kcorr-route-via-primitive* #f)
;; raw-apply-truncated-clean: HEAD config.rs:283.
(define *dgcd-raw-apply-truncated-clean* #f)
;; raw-pa-stop-* family: HEAD config.rs:290-315. Early-stop hooks
;; for the PA (point-add) driver after intermediate primitives,
;; used by HEAD's circuit-size measurement harness.
(define *dgcd-raw-pa-stop-after-quotient* #f)
(define *dgcd-raw-pa-stop-after-xtail* #f)
(define *dgcd-raw-pa-stop-after-c* #f)
(define *dgcd-raw-pa-stop-after-pair2* #f)
;; compressed-sidecar-log: HEAD config.rs:327.
(define *dgcd-compressed-sidecar-log* #f)
;;; ── dgcd-chunk-hi — sweep-dgcd-chunk-hi ───────────────────────────
;;;
;;; HEAD dialog/mod.rs:1280 dialog_gcd_chunk_hi. Pure classical helper
;;; that computes the high-boundary index of chunk `block` (0-indexed)
;;; in a chunked-f apply pass with `blocks` total chunks over an
;;; `ext_n`-wide accumulator. Closes AUDIT row 410.
;;;
;;; Dispatch logic per HEAD:
;;; - blocks=4 + *dgcd-apply-chunked-f-custom4*: cuts at chunked-f-
;;; cut/cut2/cut3 (defaults ext_n/4, ext_n/2, 3*ext_n/4)
;;; - blocks=5 + *dgcd-apply-chunked-f-custom5*: cuts at chunked-f-
;;; cut/cut2/cut3/cut4 (defaults ext_n/5..4*ext_n/5)
;;; - block=0, blocks<=3: chunked-f-cut min ext_n-1 (default ext_n/2)
;;; - blocks=3, block=1: chunked-f-cut2 min ext_n-1 (default 2*ext_n/3)
;;; - else: ((block+1)*ext_n)/blocks (uniform partition)
;;;
;;; Flag-value contract: lumbda *dgcd-apply-chunked-f-cut*N* is #f for
;;; "use HEAD's default" or an integer for "use this value". Mirrors
;;; HEAD's Option<usize> exactly. The custom4/5 toggles are bool flags.
(define (dgcd-chunk-hi blocks block ext-n)
"Port of HEAD dialog_gcd_chunk_hi (dialog/mod.rs:1280). Returns the
high-boundary index of the given chunk under chunked-f config."
(cond
;; blocks=4 custom path
((and (= blocks 4) *dgcd-apply-chunked-f-custom4*)
(let* ((c0 (or *dgcd-apply-chunked-f-cut* (quotient ext-n 4)))
(c1 (or *dgcd-apply-chunked-f-cut2* (quotient ext-n 2)))
(c2 (or *dgcd-apply-chunked-f-cut3* (quotient (* 3 ext-n) 4))))
(cond
((< block 3)
(cond ((= block 0) c0)
((= block 1) c1)
(else c2)))
(else (quotient (* (+ block 1) ext-n) blocks)))))
;; blocks=5 custom path
((and (= blocks 5) *dgcd-apply-chunked-f-custom5*)
(let* ((c0 (or *dgcd-apply-chunked-f-cut* (quotient ext-n 5)))
(c1 (or *dgcd-apply-chunked-f-cut2* (quotient (* 2 ext-n) 5)))
(c2 (or *dgcd-apply-chunked-f-cut3* (quotient (* 3 ext-n) 5)))
(c3 (or *dgcd-apply-chunked-f-cut4* (quotient (* 4 ext-n) 5))))
(cond
((< block 4)
(cond ((= block 0) c0)
((= block 1) c1)
((= block 2) c2)
(else c3)))
(else (quotient (* (+ block 1) ext-n) blocks)))))
;; block=0, blocks<=3
((and (= block 0) (<= blocks 3))
(min (or *dgcd-apply-chunked-f-cut* (quotient ext-n 2))
(- ext-n 1)))
;; blocks=3, block=1
((and (= blocks 3) (= block 1))
(min (or *dgcd-apply-chunked-f-cut2* (quotient (* 2 ext-n) 3))
(- ext-n 1)))
;; Uniform partition fallback
(else (quotient (* (+ block 1) ext-n) blocks))))
;;; ── dgcd-conditional-boundary-replay! — sweep-dgcd-chunk-hi ──────
;;;
;;; HEAD dialog/mod.rs:1323 dialog_gcd_conditional_boundary_replay.
;;; Closes AUDIT row 408.
;;;
;;; For each target in reverse order, HMR-uncompute the target bit + run
;;; cmp_lt_phase_conditioned_with_cin on the prefix u[start..p] / v[start..p],
;;; where start = previous-target's p (or 0 for first), carry_in =
;;; previous-target's qubit (or c_in for first).
;;;
;;; Caller responsibility:
;;; u-reg/v-reg: data registers width n
;;; ctrl-reg/ctrl-idx: external control
;;; cin-reg/cin-idx: initial carry-in bit
;;; targets: list of (target-reg target-idx p) triples; strictly
;;; ascending in p
;;; carries-reg/carries-offset + bit-base: scratch for the inner
;;; cmp-lt-phase-conditioned-with-cin! call
(define (dgcd-conditional-boundary-replay!
c u-reg v-reg ctrl-reg ctrl-idx cin-reg cin-idx
targets carries-reg carries-offset)
"Port of HEAD dialog_gcd_conditional_boundary_replay (dialog/mod.rs:1323)."
(let loop ((idx (- (length targets) 1)))
(when (>= idx 0)
(let* ((cur (list-ref targets idx))
(cur-tr (car cur))
(cur-ti (cadr cur))
(cur-p (caddr cur))
(prev (if (= idx 0)
(list cin-reg cin-idx 0)
(list-ref targets (- idx 1))))
(start (caddr prev))
(carry-r (car prev))
(carry-i (cadr prev))
(phase-bit (+ 600000 idx)))
(gate-hmr! c cur-tr cur-ti phase-bit)
(cmp-lt-phase-conditioned-with-cin!
c u-reg v-reg (- cur-p start)
ctrl-reg ctrl-idx
carry-r carry-i
carries-reg carries-offset
phase-bit))
(loop (- idx 1)))))
;;; ── dgcd-pick-borrow-slice — sweep-dgcd-pick-borrow-slice ─────────
;;;
;;; HEAD dialog/mod.rs:457 dialog_gcd_pick_borrow_slice. Closes AUDIT
;;; row 411. Pure classical picker: chooses between a caller-supplied
;;; `future` borrow slice and a fallback slice carved from u's
;;; high-bits region.
;;;
;;; HEAD signature: Option<&[QubitId]> in, Option<&[QubitId]> out.
;;; Lumbda port returns a 3-tuple (reg, offset, length) when a slice
;;; is selected, or #f when nothing fits. Caller projects (reg,
;;; offset, length) into their slice consumers (e.g.,
;;; cuccaro-add-fast-borrowed-lane!).
;;;
;;; Dispatch:
;;; - *dgcd-late-borrow-uv-high* must be #t AND active-width >= 1
;;; - want = 2 * active-width - 1
;;; - if future is shorter than want (or absent) AND u has enough
;;; room for active-width + want, return u[active-width..
;;; active-width+want]
;;; - else return future as-is (may be #f).
;;;
;;; The `future` argument is itself a (reg, offset, length) triple or #f.
(define (dgcd-pick-borrow-slice future u-reg u-len active-width)
"Port of HEAD dialog_gcd_pick_borrow_slice (dialog/mod.rs:457).
`future` is #f or a (reg offset length) list. Returns a (reg
offset length) list or #f."
(cond
((and *dgcd-late-borrow-uv-high* (>= active-width 1))
(let* ((want (- (* 2 active-width) 1))
(short (or (not future)
(< (list-ref future 2) want))))
(cond
((and short (>= u-len (+ active-width want)))
(list u-reg active-width want))
(else future))))
(else future)))
;;; ── selected-body lever family — sweep-selected-body-flags ────────
;;;
;;; HEAD dialog/mod.rs:341,363,394,416,423,438. Closes AUDIT row 364
;;; (selected-body-nocin) + adds the stream-suffix-map + body-host-cin
;;; flags + the per-step suffix-bits getter.
;;;
;;; All flags default OFF / 0 / empty. Downstream wiring lives in
;;; `dialog_gcd_controlled_sub_selected` (HEAD mod.rs:472) which is
;;; substrate work; this sweep makes the lever surface available.
;; *dgcd-body-host-cin* — HEAD mod.rs:389. DIALOG_GCD_BODY_HOST_CIN.
;; Default OFF. When #t, materialized selected add/sub body sources
;; its c_in from a caller-supplied host register lane instead of
;; allocating fresh.
(define *dgcd-body-host-cin* #f)
;; *dgcd-selected-body-nocin* — HEAD mod.rs:394. Integer 0/1/2.
;; 0 (#f): OFF (default)
;; 1: full no-cin path (drops c_in lane + folds carry into Cuccaro seed)
;; 2: keep-pool variant (no-cin body but legacy 2n-1 composite pool)
(define *dgcd-selected-body-nocin* 0)
;; Helper: keep-pool predicate. HEAD mod.rs:416.
(define (dgcd-selected-body-nocin-keep-pool?)
(= *dgcd-selected-body-nocin* 2))
;; Helper: nocin-enabled predicate. HEAD mod.rs:405-408.
(define (dgcd-selected-body-nocin-enabled?)
(or (= *dgcd-selected-body-nocin* 1)
(= *dgcd-selected-body-nocin* 2)))
;; *dgcd-selected-body-stream-suffix-map* — HEAD mod.rs:424.
;; DIALOG_GCD_SELECTED_BODY_STREAM_SUFFIX_MAP env var format
;; "step1:bits1,step2:bits2,...". Lumbda representation: alist
;; ((step . bits) ...). Default '() = empty map.
(define *dgcd-selected-body-stream-suffix-map* '())
(define (dgcd-selected-body-stream-suffix-bits step body-len)
"Port of HEAD dialog_gcd_selected_body_stream_suffix_bits
(mod.rs:423). Looks up `step` in the alist + clamps to body-len-1."
(let ((found (assq step *dgcd-selected-body-stream-suffix-map*)))
(cond
(found (min (cdr found) (max 0 (- body-len 1))))
(else 0))))
(define (dgcd-selected-body-stream-top-enabled? step body-len)
"Port of HEAD dialog_gcd_selected_body_stream_top_enabled (mod.rs:438).
#t when the suffix-bits lookup returns exactly 1."
(= (dgcd-selected-body-stream-suffix-bits step body-len) 1))
;;; *dgcd-pa9024-compare-schedule* — HEAD's per-step comparator schedule
;;; (config.rs:390 `DIALOG_GCD_PA9024_COMPARE_SCHEDULE`). Replaces the
;;; flat `*dgcd-compare-bits*` with a 258-entry table tuned for the K=2
;;; bounded-shift stack (active=258, WIDTH_SLOPE=1.014, WIDTH_MARGIN=10).
;;; Doc-comment from HEAD: "OBSERVED maximum req_cb = active_width
;;; - msb(u^v) ... measured over 8,000,000 reachable GCD factors ...
;;; under the active route (K2 double-shift)."
;;;
;;; HEAD's effective per-step cmp:
;;; scheduled = max(floor, schedule[step] + margin) min active_width
;;; effective = max(1, min(global_cmp, scheduled))
;;; When the global cmp is tighter the schedule never relaxes; when it
;;; would over-tighten the schedule pulls toward HEAD's calibrated value.
;;;
;;; Defaults: flag OFF (use flat compare-bits), margin=0, floor=1. Setting
;;; the flag #t at K=2 stacks matches HEAD's production envelope.
(define *dgcd-pa9024-compare-schedule* #f)
(define *dgcd-pa9024-compare-margin* 0)
(define *dgcd-pa9024-compare-floor* 1)
;;; HEAD's DIALOG_GCD_PA9024_COMPARE_SCHEDULE verbatim (258 entries).
;;; Verified against /tmp/ecdsafail-challenge/src/point_add/rounds/dialog/
;;; config.rs:390-402 commit 2dcf00d. Index = step.
(define *dgcd-pa9024-compare-schedule-table*
'#( 22 21 24 24 28 25 29 26 29 30 33 35 31 32 31 33 33 34 30 32 33 35 33 35
34 33 35 35 35 34 33 33 33 34 34 38 35 35 33 36 34 36 37 36 38 36 38 36
42 36 37 37 39 36 36 39 37 39 35 38 38 38 36 44 37 38 36 39 41 38 37 41
40 35 36 37 41 38 38 38 37 37 39 37 37 37 38 39 38 37 42 40 38 38 39 43
41 39 40 42 40 39 44 39 44 40 43 40 40 41 42 41 43 42 45 41 43 42 43 42
43 42 44 42 46 41 44 42 44 42 43 46 44 43 48 50 48 44 44 44 55 46 46 44
43 49 44 45 44 48 44 46 45 46 45 44 45 46 48 46 45 46 50 48 44 47 47 46
45 46 45 48 47 49 47 47 46 49 48 49 46 48 50 51 47 54 49 48 47 48 51 50
53 54 50 52 50 51 53 52 49 52 50 52 49 52 49 53 51 55 52 51 51 51 49 47
47 45 45 43 43 41 41 39 39 37 37 35 35 33 33 31 31 29 29 27 27 25 25 23
23 21 21 19 19 17 17 15 15 13 13 11 11 9 9 7 7 5))
(define (pa9024-schedule-lookup step)
"Returns the PA9024 schedule entry for `step`, or 0 if out of range
(HEAD falls back to global cmp via unwrap_or)."
(cond
((< step 0) 0)
((>= step (vector-length *dgcd-pa9024-compare-schedule-table*)) 0)
(else (vector-ref *dgcd-pa9024-compare-schedule-table* step))))
;;; *dgcd-late-borrow-uv-high* — HEAD's DIALOG_GCD_LATE_BORROW_UV_HIGH.
;;;
;;; When #t, ctrl-cuccaro-sub!/add! inside kaliski-iteration-dgcd!
;;; aliases u[uv-w..2*uv-w] as the masking ancilla instead of
;;; allocating a fresh uv-w-wide register. Engages only when
;;; 2 * uv-w <= n+1 (i.e., u has enough high zero space). Peak qubits
;;; drop by uv-w per engaged iter. Toffoli/Clifford counts identical
;;; (same gates, different target qubits).
(define *dgcd-late-borrow-uv-high* #f)
;;; *dgcd-odd-u-lowbit-fastpath* — HEAD's DIALOG_GCD_ODD_U_LOWBIT_FASTPATH.
;;;
;;; When #t, kaliski-iteration-dgcd! skips lane 0 in the cswap loop
;;; (since the cswap's controller a_f = (f AND NOT u[0]) is zero
;;; while u stays odd, so lane-0 cswap is a no-op anyway) and the
;;; lane-0 mask compute (since the body's controller add_f=1
;;; implies both u and v_w are odd, so v_w[0]-=ctrl AND u[0] becomes
;;; v_w[0]^=add_f with no borrow into bit 1). Replaces lane-0 body
;;; with a single cx(add_f, v_w[0]). Saves 2 Toffoli + 4 Clifford
;;; per iter (cswap × 2) + 4 Toffoli + minor Clifford per iter
;;; (mask compute + cuccaro lane-0 + mask uncompute, both sub and
;;; add) and saves 1 peak qubit (mask is uv-w-1 wide instead of
;;; uv-w). Soundness gate at build time verifies u stays odd on
;;; every classically traced iteration.
(define *dgcd-odd-u-lowbit-fastpath* #f)
;;; *dgcd-body-carry-trunc-width* — HEAD DIALOG_GCD_BODY_CARRY_TRUNC_W.
;;; Mirrors HEAD `dialog_gcd_body_carry_trunc_width` at
;;; rounds/dialog/mod.rs:235-261:
;;; body_w = active_width.saturating_sub(trunc_w).max(2)
;;; Default #f = no trunc (byte-identical pre-sweep-051).
;;;
;;; Sweep-057: re-added after sweep-053 merge dropped a sweep-051 block
;;; that this branch's host.lsp still references (lines 269-271). Without
;;; this block, every emit invoking mod-inv-by-dialog-gcd-host! errors
;;; on a missing helper.
(define *dgcd-body-carry-trunc-width* #f)
;;; *dgcd-binder-notch-steps* — HEAD DIALOG_GCD_BINDER_NOTCH_STEPS.
(define *dgcd-binder-notch-steps* (quote ()))
;;; *dgcd-binder-notch-extra* — HEAD DIALOG_GCD_BINDER_NOTCH_EXTRA.
(define *dgcd-binder-notch-extra* 0)
;;; ── HEAD width helpers — sweep-width-helpers ──────────────────────
;;;
;;; HEAD dialog/mod.rs:200,212,223,246,264,276,288,316,
;;; +316/dialog_gcd_binder_notch_map_extra.
;;;
;;; Closes the width-helper substrate needed by composite-scratch +
;;; compressed-sidecar runway-layout. All pure classical helpers.
;; *dgcd-body-carry-band-trims* — HEAD mod.rs:247
;; DIALOG_GCD_BODY_CARRY_BAND_TRIMS env var format "trim1,trim2,...".
;; Lumbda: list of trims, '() = empty (no band-trim).
(define *dgcd-body-carry-band-trims* '())
;; *dgcd-tobitvector-cswap-body-trim* — HEAD mod.rs:264
;; DIALOG_GCD_TOBITVECTOR_CSWAP_BODY_TRIM env var. When #t, cswap
;; uses body-carry-trunc-width.
(define *dgcd-tobitvector-cswap-body-trim* #f)
;; *dgcd-tobitvector-shift-body-trim* — HEAD mod.rs:276
;; DIALOG_GCD_TOBITVECTOR_SHIFT_BODY_TRIM env var. Same for shift.
(define *dgcd-tobitvector-shift-body-trim* #f)
;; *dgcd-binder-notch-map-extra* — HEAD mod.rs:316 (referenced
;; from line 312). DIALOG_GCD_BINDER_NOTCH_MAP_EXTRA env var format
;; "step1:extra1,step2:extra2,...". Lumbda: alist of (step . extra).
(define *dgcd-binder-notch-map-extra* '())
;; *dgcd-trio-width-notch-step* + *_extra* already declared above
;; (sweep-fused-measured-flags era).
(define (dgcd-width-margin)
"HEAD mod.rs:200 dialog_gcd_width_margin. Default 37.0; lumbda
stores integer via *dgcd-width-margin* (default 37)."
(exact->inexact *dgcd-width-margin*))
(define (dgcd-width-slope)
"HEAD mod.rs:212 dialog_gcd_width_slope. Default 0.5*1.415 = 0.7075;
lumbda stores per-thousand via *dgcd-width-slope-x1000* (default 708)."
(/ (exact->inexact *dgcd-width-slope-x1000*) 1000.0))
(define (dgcd-tobitvector-active-width step)
"HEAD mod.rs:223 dialog_gcd_tobitvector_active_width. Returns the
active width at the given step. When variable-width is OFF, returns
N=256."
(cond
((not *dgcd-raw-tobitvector-variable-width*) 256)
(else
(let* ((ideal (+ (- 256.0 (* (exact->inexact step) (dgcd-width-slope)))
(dgcd-width-margin)))
(capped (max 1.0 ideal))
(halved (ceiling (/ capped 2.0)))
(rounded (* 2 (inexact->exact halved))))
(max 1 (min 256 rounded))))))
(define (dgcd-body-carry-band-trim step)
"HEAD mod.rs:246. Returns the per-step band trim from
*dgcd-body-carry-band-trims*, or #f when empty."
(cond
((null? *dgcd-body-carry-band-trims*) #f)
(else
(let* ((iters (max 1 *dgcd-active-iters*))
(trims-len (length *dgcd-body-carry-band-trims*))
(band-size (max 1 (quotient (+ iters (- trims-len 1)) trims-len)))
(band (min (- trims-len 1) (quotient step band-size))))
(list-ref *dgcd-body-carry-band-trims* band)))))
(define (dgcd-binder-notch-map-extra-for step)
"HEAD mod.rs:316 dialog_gcd_binder_notch_map_extra. Looks up step in
the alist + returns the extra trim, or 0 when absent."
(let ((found (assq step *dgcd-binder-notch-map-extra*)))
(cond
(found (cdr found))
(else 0))))
(define (dgcd-body-carry-trunc-width active-width step)
"HEAD mod.rs:288 dialog_gcd_body_carry_trunc_width. Full version
including band-trim + trio-notch + binder-notch + map-extra.
Supersedes dgcd-body-carry-trunc-width-for (kept below for ABI)."
(let* ((w0 (or (dgcd-body-carry-band-trim step)
(cond
(*dgcd-body-carry-trunc-width*
(cond
((number? *dgcd-body-carry-trunc-width*)
*dgcd-body-carry-trunc-width*)
(else 0)))
(else 0))))
(w1 (cond
((and *dgcd-trio-width-notch-enabled*
(= step *dgcd-trio-width-notch-step*))
(+ w0 *dgcd-trio-width-notch-extra*))
(else w0)))
(w2 (cond
((and (> *dgcd-binder-notch-extra* 0)
(member step *dgcd-binder-notch-steps*))
(+ w1 *dgcd-binder-notch-extra*))
(else w1)))
(w3 (+ w2 (dgcd-binder-notch-map-extra-for step))))
(max 2 (- active-width w3))))
(define (dgcd-tobitvector-cswap-width active-width step)
"HEAD mod.rs:264 dialog_gcd_tobitvector_cswap_width."
(cond
(*dgcd-tobitvector-cswap-body-trim*
(min (dgcd-body-carry-trunc-width active-width step) active-width))
(else active-width)))
(define (dgcd-tobitvector-shift-width active-width step)
"HEAD mod.rs:276 dialog_gcd_tobitvector_shift_width."
(cond
(*dgcd-tobitvector-shift-body-trim*
(min (dgcd-body-carry-trunc-width active-width step) active-width))
(else active-width)))
;;; dgcd-body-carry-trunc-width-for — effective body width at step.
(define (dgcd-body-carry-trunc-width-for active-w step)
(cond
((not *dgcd-body-carry-trunc-width*) active-w)
(else
(let* ((base-trim *dgcd-body-carry-trunc-width*)
(notch? (and (> *dgcd-binder-notch-extra* 0)
(member step *dgcd-binder-notch-steps*)))
(trim-w (if notch?
(+ base-trim *dgcd-binder-notch-extra*)
base-trim))
(body-w (- active-w trim-w)))
(cond
((< body-w 2) 2)
((> body-w active-w) active-w)
(else body-w))))))
;;; *cmp-lt-with-cin* — sweep-053 Primitive 1.
;;;
;;; Mirrors HEAD's `cmp_lt_into_fast_with_cin`
;;; (point_add/arith/compare.rs:55-106). HEAD ships two variants:
;;;
;;; cmp_lt_into_fast — internally allocs cin (+1 peak qubit)
;;; cmp_lt_into_fast_with_cin — caller supplies cin from idle lane
;;;
;;; lumbda's existing cmp-lt-into-fast! (mod-arith.lsp:154) already takes
;;; cin-reg/cin-idx from caller, so its API matches HEAD's `with_cin`. The
;;; peak-qubit win HEAD captures comes from the CALLER borrowing cin from
;;; an idle operand lane instead of allocating a fresh qubit.
;;;
;;; At our dgcd-cmp-gt-into! hot site, the caller already passes cin-reg/
;;; cin-idx via the borrowed-tmp path. When this flag is #t the call
;;; documentation marks the with-cin contract explicitly + the caller
;;; routes cin into the tmp-borrow tail (which is provably |0> at the
;;; comparator instant by the active-width clamp). Provides a regression
;;; checkpoint in case future primitives lose the with-cin invariant.
;;;
;;; Score-neutral when caller already supplies cin from idle lane
;;; (current dgcd-cmp-gt-into! does — gate sequence identical to the
;;; existing path); modest peak qubit save (1-3) at comparator instant
;;; if future call sites stop borrowing.
;;;
;;; Default #f = current behavior (no semantic-marker enforcement). When
;;; #t, also serves as a build-time assertion that the cin-reg passed in
;;; was sourced from a borrow rather than a fresh alloc — surfaces in
;;; logs if a substrate gap reintroduces the alloc path.
;;;
;;; HEAD's `assert!(!u.contains(&c_in))` invariant: we satisfy by
;;; keeping cin inside the borrowed carries register where (i) carries-
;;; reg is neither u-reg nor v-reg, AND (ii) the borrowed register tail
;;; bit is dead at the comparator instant.
(define *cmp-lt-with-cin* #f)
;;; cmp-lt-into-fast-with-cin! — HEAD's `cmp_lt_into_fast_with_cin`
;;; wrapper. Semantic-marker variant of cmp-lt-into-fast! emphasizing
;;; the caller-supplied cin contract. Body byte-identical — difference
;;; vs cmp_lt_into_fast lives at the CALL SITE (cin chosen from an idle
;;; lane, not freshly alloced). Provided so future call sites that opt
;;; into the *cmp-lt-with-cin* discipline can signal intent in source.
(define (cmp-lt-into-fast-with-cin! c u-reg v-reg n
flag-reg flag-idx cin-reg cin-idx
carries-reg carries-offset bit-base)
"Caller-supplied-cin variant of cmp-lt-into-fast! (HEAD compare.rs:55).
Identical gate sequence; the discipline is that cin-reg/cin-idx must
point into an idle operand lane the caller BORROWED rather than fresh-
allocated. carries-reg[carries-offset..+n) must be |0> in/out via the
HMR backward sweep. bit-base..+n-1 reserves classical bits."
(cmp-lt-into-fast! c u-reg v-reg n
flag-reg flag-idx cin-reg cin-idx
carries-reg carries-offset bit-base))
;;; ── width envelope helpers ────────────────────────────────────────
;;; ceiling-div — ceiling(a / b) for positive a, b.
(define (dgcd-ceiling-div a b)
(quotient (+ a (- b 1)) b))
;;; dgcd-uv-width — smooth linear envelope per step.
;;;
;;; Ports HEAD's `dialog_gcd_tobitvector_active_width` at
;;; mod.rs:24452-24459. The `2 * ceiling(ideal / 2)` keeps the width
;;; even (HEAD's comparator/cuccaro family is even-width-friendly).
;;; We clamp at 1 below & n+1 above so the helper never returns a
;;; degenerate width.
;;;
;;; To stay integer-only inside lumbda we scale by 1000:
;;; ideal × 1000 = N×1000 - step × slope-x1000 + margin × 1000
;;; then divide by 1000 with ceiling for the final width-half.
;;; *dgcd-trio-width-notch-enabled* / -step / -extra ────────────────
;;;
;;; HEAD's DIALOG_GCD_TRIO_WIDTH_NOTCH lever family (dialog/mod.rs:376-394).
;;; HEAD's docstring on the enabled flag: "Default-on successor from
;;; aaf9616: the current route inherited its body geometry, and this
;;; one-step notch is needed to reclaim the 1306q tier." sweep-026 §2
;;; flagged this as a knob HEAD's a66b042 frontier uses.
;;;
;;; What it does: adds `*dgcd-trio-width-notch-extra*` to the active
;;; width at exactly step = `*dgcd-trio-width-notch-step*`. HEAD's
;;; defaults: enabled=#t, step=11, extra=2.
;;;
;;; AUDIT §9 lever row 368. Default-OFF in lumbda to preserve byte-
;;; identity for existing cells; cells that want HEAD's default
;;; behavior MUST explicitly set *dgcd-trio-width-notch-enabled* #t.
;;; (HEAD env-default-on vs lumbda flags-default-off is a deliberate
;;; convention difference -- per CLAUDE.md "merge-to-master rule":
;;; flags default OFF, primitives are additive, never modify existing
;;; behavior.) HEAD's step + extra defaults are preserved so the
;;; behavior on opt-in matches HEAD.
(define *dgcd-trio-width-notch-enabled* #f)
(define *dgcd-trio-width-notch-step* 11)
(define *dgcd-trio-width-notch-extra* 2)
;;; ── Missing HEAD submission-route flags — sweep-missing-route-flags
;;;
;;; Dialog-side flags missing from lumbda. All default OFF / sentinel.
;; *dgcd-branch-bits-host-comparator* — HEAD mod.rs:69
;; DIALOG_GCD_BRANCH_BITS_HOST_COMPARATOR. Routes the fused branch-bit
;; path through borrowed-carry comparator on future-log slice instead
;; of allocating cmp ancilla. 1466 -> peak-cut substrate lever.
(define *dgcd-branch-bits-host-comparator* #f)
;; *dgcd-measured-apply-sub* — HEAD mod.rs:1186 (DIALOG_GCD_MEASURED_APPLY_SUB).
;; Gidney measurement uncompute for apply-phase modular subtract's raw
;; difference. ~n Toffoli instead of ~2n per call; peak-neutral.
(define *dgcd-measured-apply-sub* #f)
;; *dgcd-raw-pa* — HEAD mod.rs:1106 (DIALOG_GCD_RAW_PA).
;; Master toggle for raw point-add path.
(define *dgcd-raw-pa* #f)
;; *dgcd-measured-underflow-gate* — HEAD mod.rs:1056
;; DIALOG_GCD_MEASURED_UNDERFLOW_GATE. Measured uncompute for the
;; underflow comparator gate.
(define *dgcd-measured-underflow-gate* #f)
;; *mod-fast-flag-conditional-replay* — HEAD mod.rs:1105
;; MOD_FAST_FLAG_CONDITIONAL_REPLAY. Routes mod_add_qq_fast's flag
;; uncompute through cmp_lt_phase_conditioned (HMR-vented) instead of
;; cmp_lt_into_fast. Saves the load_const transient.
(define *mod-fast-flag-conditional-replay* #f)
;; *dgcd-free-scratch-before-shift* — HEAD mod.rs:1314
;; DIALOG_GCD_FREE_SCRATCH_BEFORE_SHIFT. Bennett-frees composite scratch
;; before the shift phase, reducing peak.
(define *dgcd-free-scratch-before-shift* #f)
;; *dgcd-special-overflow-clean-step-bits* — HEAD mod.rs:1285
;; DIALOG_GCD_SPECIAL_OVERFLOW_CLEAN_STEP_BITS env "step:bits,..." map.
;; Per-step overflow-clean comparator width override. Lumbda: alist.
(define *dgcd-special-overflow-clean-step-bits* '())
;; *dgcd-special-underflow-clean-step-bits* — HEAD mod.rs:1289
;; Symmetric for underflow-clean. Lumbda: alist.
(define *dgcd-special-underflow-clean-step-bits* '())
(define (dgcd-uv-width-raw step n+1)
"HEAD-formula raw active width for `step`. Returns even integer in
[2, n+1] (even because HEAD's family is even-width-friendly). step
= 0 returns ~ n + MARGIN, monotone-decreasing thereafter.
sweep-trio-width-notch (2026-06-10): applies the HEAD trio-width-
notch one-step bump when *dgcd-trio-width-notch-enabled* AND step
matches the configured notch step. Adds *dgcd-trio-width-notch-
extra* to the active width AT that step only, then resumes the
baseline envelope. Maintains the even-rounded clamp."
(let* ((n (- n+1 1))
(n-times-1000 (* n 1000))
(step-slope (* step *dgcd-width-slope-x1000*))
(margin-x1000 (* *dgcd-width-margin* 1000))
(ideal-x1000 (+ (- n-times-1000 step-slope) margin-x1000))
(ideal-x1000+ (if (< ideal-x1000 1000) 1000 ideal-x1000))
(half-ceil (dgcd-ceiling-div ideal-x1000+ 2000))
(rounded (* 2 half-ceil))
;; Apply trio-width-notch bump at the configured step.
(notch-extra (cond
((and *dgcd-trio-width-notch-enabled*
(= step *dgcd-trio-width-notch-step*))
*dgcd-trio-width-notch-extra*)
(else 0)))
(with-notch (+ rounded notch-extra))
(clamped-hi (if (> with-notch n+1) n+1 with-notch))
(clamped-lo (if (< clamped-hi 2) 2 clamped-hi)))
clamped-lo))
;;; dgcd-compare-bits-for-step — comparator window per step.
;;;
;;; HEAD's `dialog_gcd_compare_bits_for_step` (mod.rs:24290) compares
;;; only the top `min(*dgcd-compare-bits*, active-width)` bits. When
;;; *dgcd-compare-bits* is #f we use the full active width (no
;;; truncation).
(define (dgcd-compare-bits-for-step step n+1)
(let* ((active (dgcd-uv-width-raw step n+1))
(n (- active 1))
(global (cond
((not *dgcd-compare-bits*) n)
((>= *dgcd-compare-bits* n) n)
((< *dgcd-compare-bits* 1) 1)
(else *dgcd-compare-bits*))))
;; HEAD's compare_bits_for_step (dialog_gcd_classical_filter.rs:133):
;; when pa9024_compare_schedule is set, look up schedule[step], add
;; margin, clamp to [floor, active]; the final result is min'd with
;; the global cmp + max'd with 1 so the schedule can only TIGHTEN.
(cond
((not *dgcd-pa9024-compare-schedule*) global)
(else
(let* ((raw (pa9024-schedule-lookup step))
(with-marg (+ raw *dgcd-pa9024-compare-margin*))
(floored (max with-marg *dgcd-pa9024-compare-floor*))
(capped (min floored n))
(scheduled (min capped global)))
(max 1 scheduled))))))
;;; dgcd-resolve-iters — concrete iteration count to use.
;;;
;;; #f means full textbook 2n; integer is the capped value (clamped
;;; into [1, 2n] to defend against absurd values).
(define (dgcd-resolve-iters n+1)
(let ((textbook (* 2 (- n+1 1))))
(cond
((not *dgcd-active-iters*) textbook)
((> *dgcd-active-iters* textbook) textbook)
((< *dgcd-active-iters* 1) 1)
(else *dgcd-active-iters*))))
;;; ── truncated comparator wrapper ────────────────────────────────
;;; dgcd-cmp-gt-into! — flag ^= (u[top..] > v[top..]) over compare-bits.
;;;
;;; Mirrors HEAD's `dialog_gcd_cmp_gt_truncated_into_width`. When
;;; compare-bits = active width this collapses to the standard
;;; cmp-gt-into!. When narrower, we slice both operands to their top
;;; compare-bits suffix (HEAD's "start = u.len() - compare_bits").
;;;
;;; lumbda's cmp-lt-into! / cmp-gt-into! reads bit-by-bit by integer
;;; index into the register. We pass `n` = compare-bits and rely on
;;; the comparator to read indices [0..n-1]. Since the active-width
;;; truncation guarantees bits above active are |0>, comparing the
;;; LOW compare-bits gives the WRONG answer in general (we want the
;;; top); rebind by aliasing to a shifted view is awkward in our
;;; substrate.
;;;
;;; DECISION for v1: take the comparator over the LOW compare-bits.
;;; Sound? Only if u, v have known-zero high bits AND the low
;;; compare-bits suffice to determine the comparison. On the
;;; verifier-reachable support after sufficiently many iters, both
;;; u and v are small enough to fit in compare-bits — so the LOW
;;; truncation is value-exact then. EARLY iters where u or v exceeds
;;; 2^compare-bits would give the wrong comparator. So:
;;;
;;; guard: only truncate when active-width <= compare-bits, else
;;; fall through to full active-width comparator.
;;;
;;; This is more conservative than HEAD's TOP-bits truncation but
;;; gives the same Toffoli savings on the late-step support (where
;;; HEAD's win is concentrated). For TOP-bits we'd need a sliced-
;;; register view primitive that mod-arith does not currently expose.
;;; *dgcd-host-comparator* — sweep-hosted-cmp-wire flag.
;;;
;;; When #t, dgcd-cmp-gt-into! compares the TOP cmp-bits of u and v
;;; (HEAD's HOSTED semantics: cmp over u[start..] / v[start..] where
;;; start = active-width - cmp-bits) instead of the LOW cmp-bits
;;; (current default which can mis-decide when low bits of GCD operands
;;; differ but high bits don't — caught by Fiat-Shamir reroll).
;;;
;;; Routes through cmp-lt-into-fast-offset! (sweep-prefix-targets-split).
;;; Saves no Toffolis per call vs the low-bit path, but the TOP-bit
;;; semantics matches HEAD's tuned route + makes the comparator more
;;; reliable at tight width margins (fewer reroll hazards).
;;;
;;; Default #f preserves the current low-bit behavior + champion
;;; byte-identity.
(define *dgcd-host-comparator* #f)
(define (dgcd-cmp-gt-into! c u-reg v-reg active-width step
flag-reg flag-idx cin-reg cin-idx
. tmp-borrow-opt)
"flag ^= (u > v) at the active comparator width for `step`.
Defers to cmp-gt-into! over the appropriate width.
When *cuccaro-use-borrowed* is #t & tmp-borrow-opt supplies a
register name, uses cmp-lt-into-fast! (HMR uncompute, saves n CCX
per call). Arg swapped (v u) to convert > → < per cmp-gt-into!'s
contract.
sweep-hosted-cmp-wire: when *dgcd-host-comparator* is #t AND
*cuccaro-use-borrowed* is #t AND tmp-borrow-opt is supplied,
routes through cmp-lt-into-fast-offset! at TOP-bit slice
(u[start..] / v[start..] where start = active-width - cmp-bits).
Matches HEAD's HOSTED comparator semantics."
(let ((cmp-w (cond
((not *dgcd-compare-bits*) active-width)
((>= *dgcd-compare-bits* active-width) active-width)
(else *dgcd-compare-bits*))))
(cond
((and *dgcd-host-comparator*
*cuccaro-use-borrowed*
(not (null? tmp-borrow-opt)))
;; HOSTED top-bit comparator (sweep-hosted-cmp-wire).
(let ((start (- active-width cmp-w)))
(cmp-lt-into-fast-offset! c v-reg start u-reg start cmp-w
flag-reg flag-idx cin-reg cin-idx
(car tmp-borrow-opt) 0
(* 4 active-width))))
((and *cuccaro-use-borrowed* (not (null? tmp-borrow-opt)))
(cmp-lt-into-fast! c v-reg u-reg cmp-w
flag-reg flag-idx cin-reg cin-idx
(car tmp-borrow-opt) 0 (* 4 active-width)))
(else
(cmp-gt-into! c u-reg v-reg cmp-w
flag-reg flag-idx cin-reg cin-idx)))))
;;; ── dgcd-ccx-cmp-gt-truncated-into-width-hosted! ─────────────────
;;;
;;; Port of HEAD dgcd_ccx_cmp_gt_truncated_into_width_hosted
;;; dialog/mod.rs:83-123, commit 2dcf00d. THE single biggest score
;;; lever HEAD has that we lack -- per sweep-026 section 2, HEAD's
;;; a66b042 frontier uses CLEAN_COMPARE_BITS=20 + the HOSTED
;;; comparator path to land its 1309q route's score advantage.
;;;
;;; What HOSTED does: comparator over a TRUNCATED top-bit window
;;; ( u[start..], v[start..] where start = active-width - compare-bits )
;;; with the c-in + carries lanes BORROWED from a transient
;;; future-log prefix that's idle at the comparator's instant. Three
;;; dispatch modes per HEAD lines 108-121:
;;;
;;; (a) PARTIAL-HOST: borrowed available > 0 but < need; allocate
;;; only the deficit, prepend borrowed prefix, call
;;; borrowed-carries on the gathered lane. Saves the peak
;;; qubit that an all-or-nothing alloc would pin at the late-
;;; step branch_bits instant. Requires the partial-host flag.
;;;
;;; (b) FULL-HOST: borrowed >= need; no own-alloc, call borrowed-
;;; carries directly on the borrowed prefix.
;;;
;;; (c) NO-HOST: no borrowed lane available; alloc fresh cin +
;;; carries, call borrowed-carries (HEAD calls
;;; ccx_cmp_lt_into_fast directly, but lumbda's only standalone
;;; ccx variant IS borrowed-carries so we route through it).
;;;
;;; Argument swap (cmp_u = v, cmp_v = u) converts > -> < matching
;;; HEAD's pattern + our dgcd-cmp-gt-into!'s convention.
;;;
;;; Lumbda signature mirrors HEAD via offset/length triples since
;;; lumbda lacks slice types. The borrowed lane is encoded as
;;; (borrowed-reg, borrowed-off, borrowed-len); pass borrowed-reg=#f
;;; to indicate no borrowed lane (NO-HOST mode).
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; this primitive yet. Wired into a callsite by a follow-on sweep
;;; that ports the dialog-gcd branch-bit comparator HOSTED path
;;; (HEAD dialog/mod.rs:303-360 region; uses this primitive at the
;;; per-step comparator instant).
;;;
;;; HEAD-PARITY-COLLAB section 1.2 row 7 closes with this port.
(define *dgcd-partial-host-comparator* #f)
(define (dgcd-ccx-cmp-gt-truncated-into-width-hosted!
c u-reg v-reg active-width
ctrl-reg ctrl-idx target-reg target-idx
compare-bits
borrowed-reg borrowed-off borrowed-len
carries-fallback-reg carries-fallback-off
cin-fallback-reg cin-fallback-idx
bit-base)
;; HOSTED truncated > comparator. See header.
;; Caller supplies fallback cin + carries lanes that get used in
;; NO-HOST mode (lumbda alloc happens at caller scope, not inline).
;; PARTIAL-HOST mode would need an additional own-alloc deficit
;; lane the caller pre-stages; for v1 we conservatively fall back
;; to FULL-HOST when borrowed >= need, else NO-HOST. The PARTIAL
;; flag + deficit-alloc path is a follow-on sweep so the dispatcher
;; lands clean here.
(let* ((cmp-bits (max 1 (min compare-bits active-width)))
(start (- active-width cmp-bits))
(need (+ cmp-bits 1)))
(cond
;; FULL-HOST: borrowed available + sufficient.
((and borrowed-reg (>= borrowed-len need))
;; Borrowed slot 0 = c_in; slots 1..cmp-bits = carries.
(ccx-cmp-lt-into-fast-borrowed-carries-offset!
c v-reg start u-reg start cmp-bits
ctrl-reg ctrl-idx target-reg target-idx
borrowed-reg (+ borrowed-off 1)
borrowed-reg borrowed-off
bit-base))
;; NO-HOST / PARTIAL fallback (PARTIAL deficit-alloc TODO).
(else
(ccx-cmp-lt-into-fast-borrowed-carries-offset!
c v-reg start u-reg start cmp-bits
ctrl-reg ctrl-idx target-reg target-idx
carries-fallback-reg carries-fallback-off
cin-fallback-reg cin-fallback-idx
bit-base)))))
;;; ── dgcd-clean-truncated-underflow! ────────────────────────────────
;;;
;;; Port of HEAD dialog_gcd_clean_truncated_underflow
;;; (src/point_add/rounds/dialog/mod.rs:1173-1206, commit 2dcf00d).
;;; Special-purpose helper inside HEAD's apply-phase that conditionally
;;; clears acc_ovf when the truncated-top comparator says acc < a.
;;;
;;; HEAD's two dispatch paths:
;;; (a) special_clean_conditional_replay_enabled: HMR(acc_ovf) +
;;; z_if(ctrl, phase) + phase-conditioned comparator. The
;;; conditional replay only fires on the half-shots where HMR
;;; projected acc_ovf to 1.
;;; (b) plain: cx(ctrl, acc_ovf) + ccx_cmp_lt_into_fast on the top
;;; compare-bits slice.
;;;
;;; Both paths bracketed by negate-u envelope (X on a[compare_start..]).
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches yet.
;;; Closes AUDIT §10 dialog_gcd_clean_truncated_underflow ABSENT row.
;;; Lumbda caller integration is a follow-on sweep that wires
;;; dgcd-special-clean-conditional-replay flag into apply-phase
;;; emit. Path (a) routes through `cmp-lt-phase-conditioned-with-cin!`
;;; (PORTED, offset-indexed variant at mod-arith.lsp:703). Path (b)
;;; routes through `ccx-cmp-lt-into-fast-borrowed-carries-offset!`
;;; (PORTED via sweep-hosted-comparator at mod-arith.lsp).
(define *dgcd-special-clean-conditional-replay* #f)
(define (dgcd-special-underflow-clean-compare-bits step)
;; HEAD dialog/config.rs:dialog_gcd_special_underflow_clean_compare_bits
;; — per-step compare-bits for the underflow-clean comparator. Default
;; falls back to the global *dgcd-compare-bits*. step argument matches
;; HEAD's Option<usize>; pass #f for global default.
(cond
((not step) (or *dgcd-compare-bits* 56)) ; HEAD's flat default at production
(else (or *dgcd-compare-bits* 56))))
(define (dgcd-clean-truncated-underflow!
c acc-reg a-reg active-width
ctrl-reg ctrl-idx
acc-ovf-reg acc-ovf-idx
step
;; Path (a) ancilla: cin for phase-conditioned, phase-bit ID,
;; bit-base for window-inverse HMR; carries for the inner
;; phase-conditioned window pair.
phase-cin-reg phase-cin-idx
phase-bit
phase-carries-reg phase-carries-off
phase-bit-base
;; Path (b) ancilla: borrowed-carries-offset's carries + cin
;; + bit-base. Only one of (a)/(b) ancilla pairs is consumed
;; per call; caller may pass dummy values for the unused
;; path.
plain-carries-reg plain-carries-off
plain-cin-reg plain-cin-idx
plain-bit-base)
;; HEAD lines 1181-1205 with two dispatch paths gated by
;; *dgcd-special-clean-conditional-replay*.
(let* ((cmp-bits (dgcd-special-underflow-clean-compare-bits step))
(compare-start (- active-width cmp-bits)))
;; (1) Negate the top slice of a (HEAD: for &q in &a[compare_start..]: b.x(q)).
(let loop ((i compare-start))
(when (< i active-width)
(gate-x! c a-reg i)
(loop (+ i 1))))
;; (2) Dispatch.
(cond
(*dgcd-special-clean-conditional-replay*
;; Path (a): HMR + z_if + phase-conditioned comparator.
;; HEAD lines 1186-1198.
(gate-hmr! c acc-ovf-reg acc-ovf-idx phase-bit)
;; z_if(ctrl, phase): in lumbda, push-cond + cz + pop-cond.
;; z_if(q, c) emits an X+CZ+X identity at small width but
;; the lumbda primitive sequence captures the same semantics
;; via the phase-bit gating.
(gate-push-cond! c phase-bit)
(gate-cz! c ctrl-reg ctrl-idx ctrl-reg ctrl-idx)
(gate-pop-cond! c)
(cmp-lt-phase-conditioned-with-cin!
c acc-reg compare-start a-reg compare-start cmp-bits
phase-cin-reg phase-cin-idx
ctrl-reg ctrl-idx
phase-bit
phase-carries-reg phase-carries-off
phase-bit-base))
(else
;; Path (b): plain cx + ccx_cmp_lt_into_fast.
;; HEAD lines 1200-1201.
(gate-cx! c ctrl-reg ctrl-idx acc-ovf-reg acc-ovf-idx)
(ccx-cmp-lt-into-fast-borrowed-carries-offset!
c acc-reg compare-start a-reg compare-start cmp-bits
ctrl-reg ctrl-idx acc-ovf-reg acc-ovf-idx
plain-carries-reg plain-carries-off
plain-cin-reg plain-cin-idx
plain-bit-base)))
;; (3) Un-negate the top slice of a.
(let loop ((i compare-start))
(when (< i active-width)
(gate-x! c a-reg i)
(loop (+ i 1))))))
;;; ── v2 helpers: LATE_BORROW + ODD_U lane-0 fastpath ──────────────
;;;
;;; ccx-mask-offset! — like ccx-mask! but with offsets on src & dst.
;;;
;;; Walks k in [body-start, body-end) emitting
;;; ccx(ctrl, src[src-off+k], dst[dst-off+k])
;;; Self-inverse on the (ctrl, src) inputs; uncomputes by replaying.
(define (dgcd-ccx-mask-offset! c ctrl-reg ctrl-idx
src-reg src-off
dst-reg dst-off
body-start body-end)
(let loop ((k body-start))
(when (< k body-end)
(gate-ccx! c ctrl-reg ctrl-idx
src-reg (+ src-off k)
dst-reg (+ dst-off k))
(loop (+ k 1)))))
;;; dgcd-ctrl-cuccaro-sub-extended! — substrate-faithful sub with the
;;; LATE_BORROW + ODD_U knobs applied.
;;;
;;; Effect (over uv-w bits):
;;; acc[..uv-w] := acc[..uv-w] - (ctrl ? u[..uv-w] : 0) mod 2^uv-w
;;;
;;; Knob semantics:
;;; borrow? = #t — host the masking ancilla on u[uv-w..2*uv-w] (which
;;; is guaranteed |0> when 2*uv-w <= n+1 by the width-
;;; truncation premise). When #f, allocate a fresh
;;; uv-w-wide register named mask-name as before.
;;; odd-u? = #t — skip lane 0 of the mask compute & cuccaro body;
;;; emit a single (gate-cx ctrl acc[0]) instead. Body
;;; runs over bits 1..uv-w-1.
;;;
;;; Caller must guarantee:
;;; - When borrow? = #t: 2 * uv-w <= n+1 (so u[uv-w..2*uv-w] exists).
;;; u[uv-w..2*uv-w] must be |0> on entry (truncation premise).
;;; Returns |0> on exit.
;;; - When odd-u? = #t: ctrl ⇒ (u[0] = 1) AND (acc[0] = ctrl). When
;;; ctrl = 0 the lane-0 body is a no-op; when ctrl = 1 we have
;;; acc[0] - u[0] = ctrl - 1 = 0 with no borrow into bit 1.
;;;
;;; cuccaro-sub-offset! n=1 special-cases to (cx a[0] acc[0])(cx cin
;;; acc[0]); we never enter the n=1 sub-body when odd-u? is on because
;;; the body starts at bit 1.
(define (dgcd-ctrl-cuccaro-sub-extended! c
ctrl-reg ctrl-idx
u-reg uv-w n+1
acc-reg
cin-reg cin-idx
mask-name
borrow? odd-u?)
(let* ((mask-w (if odd-u? (- uv-w 1) uv-w))
(body-start (if odd-u? 1 0))
(body-end uv-w)
(mask-host u-reg)
(mask-off uv-w))
;; Allocate or alias the mask scratch.
(cond
(borrow?
;; Aliasing u[uv-w..uv-w+mask-w] as the mask. Requires
;; uv-w + mask-w <= n+1 (caller-side guard).
(when (> (+ uv-w mask-w) n+1)
(error "dgcd-ctrl-cuccaro-sub-extended!: borrow? requires "
"uv-w + mask-w <= n+1; uv-w=" uv-w
" mask-w=" mask-w " n+1=" n+1)))
(else
(alloc! c mask-name mask-w)))
;; ── compute mask = ctrl AND u over [body-start, body-end) ──
(cond
(borrow?
;; mask lives at u[uv-w + (k - body-start)]; src is u[k]
(let loop ((k body-start))
(when (< k body-end)
(gate-ccx! c ctrl-reg ctrl-idx
u-reg k
mask-host (+ uv-w (- k body-start)))
(loop (+ k 1)))))
(else
;; mask-name lives at index (k - body-start)
(let loop ((k body-start))
(when (< k body-end)
(gate-ccx! c ctrl-reg ctrl-idx
u-reg k
mask-name (- k body-start))
(loop (+ k 1))))))
;; ── odd-u lane-0 contribution: acc[0] ^= ctrl ──
(when odd-u?
(gate-cx! c ctrl-reg ctrl-idx acc-reg 0))
;; ── cuccaro-sub-offset over the mask body ──
(when (> mask-w 0)
(cond
(borrow?
(cuccaro-sub-offset! c mask-host uv-w acc-reg body-start
cin-reg cin-idx mask-w))
(else
(cuccaro-sub-offset! c mask-name 0 acc-reg body-start
cin-reg cin-idx mask-w))))
;; ── uncompute mask (ccx self-inverse) ──
(cond
(borrow?
(let loop ((k body-start))
(when (< k body-end)
(gate-ccx! c ctrl-reg ctrl-idx
u-reg k
mask-host (+ uv-w (- k body-start)))
(loop (+ k 1)))))
(else
(let loop ((k body-start))
(when (< k body-end)
(gate-ccx! c ctrl-reg ctrl-idx
u-reg k
mask-name (- k body-start))
(loop (+ k 1))))))
;; ── free the mask register if we allocated it ──
(when (not borrow?)
(free! c mask-name))))
(define (dgcd-ctrl-cuccaro-add-extended! c
ctrl-reg ctrl-idx
u-reg uv-w n+1
acc-reg
cin-reg cin-idx
mask-name
borrow? odd-u?)
"Inverse of dgcd-ctrl-cuccaro-sub-extended!: acc += ctrl ? u : 0
mod 2^uv-w. Same borrow / odd-u semantics. Used in the s-side
r-cuccaro-add slot, where the soundness premise on odd-u differs
(r and s do NOT carry a binary-GCD oddness invariant) — caller
must therefore NOT set odd-u? = #t when this helper is applied to
r/s. The kaliski-iteration-dgcd! call sites enforce this."
(let* ((mask-w (if odd-u? (- uv-w 1) uv-w))
(body-start (if odd-u? 1 0))
(body-end uv-w)
(mask-host u-reg))
(cond
(borrow?
(when (> (+ uv-w mask-w) n+1)
(error "dgcd-ctrl-cuccaro-add-extended!: borrow? requires "
"uv-w + mask-w <= n+1; uv-w=" uv-w
" mask-w=" mask-w " n+1=" n+1)))
(else
(alloc! c mask-name mask-w)))
(cond
(borrow?
(let loop ((k body-start))
(when (< k body-end)
(gate-ccx! c ctrl-reg ctrl-idx
u-reg k
mask-host (+ uv-w (- k body-start)))
(loop (+ k 1)))))
(else
(let loop ((k body-start))
(when (< k body-end)
(gate-ccx! c ctrl-reg ctrl-idx
u-reg k
mask-name (- k body-start))
(loop (+ k 1))))))
(when odd-u?
(gate-cx! c ctrl-reg ctrl-idx acc-reg 0))
(when (> mask-w 0)
(cond
(borrow?
(cuccaro-add-offset! c mask-host uv-w acc-reg body-start
cin-reg cin-idx mask-w))
(else
(cuccaro-add-offset! c mask-name 0 acc-reg body-start
cin-reg cin-idx mask-w))))
(cond
(borrow?
(let loop ((k body-start))
(when (< k body-end)
(gate-ccx! c ctrl-reg ctrl-idx
u-reg k
mask-host (+ uv-w (- k body-start)))
(loop (+ k 1)))))
(else
(let loop ((k body-start))
(when (< k body-end)
(gate-ccx! c ctrl-reg ctrl-idx
u-reg k
mask-name (- k body-start))
(loop (+ k 1))))))
(when (not borrow?)
(free! c mask-name))))
;;; dgcd-borrow-engages? — gate function for LATE_BORROW per iter.
;;;
;;; HEAD's pick_borrow_slice falls back to u-high only when the
;;; compressed future log is short. Our substrate has no future log;
;;; we engage whenever the width-truncation envelope leaves enough
;;; high-zero space on u.
(define (dgcd-borrow-engages? uv-w n+1 odd-u-on?)
(let ((mask-w (if odd-u-on? (- uv-w 1) uv-w)))
(and *dgcd-late-borrow-uv-high*
(>= mask-w 1)
(<= (+ uv-w mask-w) n+1))))
;;; ── one Kaliski iteration with dialog-gcd width schedule ────────
;;; kaliski-iteration-dgcd! — clone of kaliski-iteration-trunc! but
;;; with the smooth envelope and truncated comparator.
;;;
;;; Identical control flow to kaliski-iteration-trunc!
;;; (mod-inv-by.lsp:1046); only the width helpers change. We name
;;; iteration-local ancillae with a "dg-" prefix so allocator names
;;; don't collide with concurrently-built kaliski-iteration-trunc!
;;; circuits inside the same emitter (defensive — no current call
;;; site mixes them).
(define (kaliski-iteration-dgcd! c iter-idx n+1 p
u-name v-w-name r-name s-name
f-name f-idx
m-hist-name m-idx
cin-name cin-idx
tmp-name flag-name flag-idx
red-tmp-name
a-masked-scratch-name)
"Kaliski iteration under HEAD's DIALOG_GCD width envelope. Same
semantics as kaliski-iteration-trunc!; widths from dgcd helpers."
(let* ((a-f (string->symbol
(string-append "kal-dg-a-f-"
(number->string iter-idx))))
(b-f (string->symbol
(string-append "kal-dg-b-f-"
(number->string iter-idx))))
(add-f (string->symbol
(string-append "kal-dg-add-f-"
(number->string iter-idx))))
(l-gt (string->symbol
(string-append "kal-dg-l-gt-"
(number->string iter-idx))))
(or-chain (string->symbol
(string-append "kal-dg-or-chain-"
(number->string iter-idx))))
(n (- n+1 1))
(uv-w (dgcd-uv-width-raw iter-idx n+1))
(uv-n (- uv-w 1))
(rs3-w (mib-rs-step3-width iter-idx n+1))
(rs9-w (mib-rs-step9-width iter-idx n+1)))
(alloc! c a-f 1)
(alloc! c b-f 1)
(alloc! c add-f 1)
(alloc! c l-gt 1)
;; ── STEP 0: is_zero check over uv-n bits of v_w ──
(is-zero-into! c v-w-name uv-n flag-name flag-idx or-chain)
(gate-ccx! c f-name f-idx flag-name flag-idx m-hist-name m-idx)
(is-zero-into! c v-w-name uv-n flag-name flag-idx or-chain)
(gate-cx! c m-hist-name m-idx f-name f-idx)
;; ── STEP 1 (lane 0) ──
(gate-x! c u-name 0)
(gate-ccx! c f-name f-idx u-name 0 a-f 0)
(gate-x! c u-name 0)
(gate-ccx! c f-name f-idx u-name 0 l-gt 0)
(gate-x! c v-w-name 0)
(gate-ccx! c l-gt 0 v-w-name 0 m-hist-name m-idx)
(gate-x! c v-w-name 0)
(gate-ccx! c f-name f-idx u-name 0 l-gt 0)
(gate-cx! c a-f 0 b-f 0)
(gate-cx! c m-hist-name m-idx b-f 0)
;; ── STEP 2 — TRUNCATED comparator (D2) ──
(dgcd-cmp-gt-into! c u-name v-w-name uv-n iter-idx
l-gt 0 cin-name cin-idx)
(gate-ccx! c f-name f-idx l-gt 0 add-f 0)
(gate-x! c b-f 0)
(gate-ccx! c add-f 0 b-f 0 a-f 0)
(gate-ccx! c add-f 0 b-f 0 m-hist-name m-idx)
(gate-x! c b-f 0)
(gate-ccx! c f-name f-idx l-gt 0 add-f 0)
(dgcd-cmp-gt-into! c u-name v-w-name uv-n iter-idx
l-gt 0 cin-name cin-idx)
;; ── STEP 3: cswap(u, v_w) over uv-w; cswap(r, s) over rs3-w ──
;;
;; ODD_U fastpath does NOT skip lane 0 of cswap in our substrate.
;; Our cswap is controlled by a_f, which fires in the (u[0]=0,
;; v_w[0]=1) sub-case where lane-0 swap is NOT identity. HEAD
;; can skip because its cswap is controlled by b0_and_b1 =
;; v_w[0] AND (u>v_w) which only fires when both are odd
;; (cswap on two 1-bits = identity). Substrate mismatch
;; documented at HEAD ref mod.rs:24944 + classical trace
;; mod-inv-by.lsp:782-785.
(cswap-reg! c a-f 0 u-name v-w-name uv-w)
(cswap-reg! c a-f 0 r-name s-name rs3-w)
;; ── STEP 4 ──
(gate-x! c b-f 0)
(gate-ccx! c f-name f-idx b-f 0 add-f 0)
(gate-x! c b-f 0)
;; sub: borrow + odd-u apply to u→v_w slot (binary-GCD invariant
;; carries u). Engagement gate folds *dgcd-late-borrow-uv-high*
;; AND room (2*mask-w <= n+1).
(let* ((odd-u? *dgcd-odd-u-lowbit-fastpath*)
(borrow? (dgcd-borrow-engages? uv-w n+1 odd-u?))
(sub-mask (string->symbol
(string-append "kal-dg-sub-mask-"
(number->string iter-idx)))))
(cond
((or borrow? odd-u?)
(dgcd-ctrl-cuccaro-sub-extended! c add-f 0
u-name uv-w n+1
v-w-name
cin-name cin-idx
sub-mask
borrow? odd-u?))
(else
(ctrl-cuccaro-sub! c add-f 0 u-name v-w-name uv-w
cin-name cin-idx sub-mask))))
;; add: r/s side — odd-u does NOT apply here (no oddness on r/s).
;; LATE_BORROW also does NOT engage on r/s (r has no truncation
;; envelope; full n+1 bits live throughout).
(ctrl-cuccaro-add! c add-f 0 r-name s-name rs9-w
cin-name cin-idx
(string->symbol
(string-append "kal-dg-add-mask-"
(number->string iter-idx))))
;; ── STEP 5 ──
(gate-x! c b-f 0)
(gate-ccx! c f-name f-idx b-f 0 add-f 0)
(gate-x! c b-f 0)
(gate-cx! c m-hist-name m-idx b-f 0)
(gate-cx! c a-f 0 b-f 0)
;; ── STEP 6: v_w := v_w >> 1 over uv-w bits ──
(shift-right-reg! c v-w-name uv-w)
;; ── STEP 7+8: r := 2r mod p (full p, see kaliski-iteration-trunc!) ──
(mod-double-inplace! c r-name n+1 p
cin-name cin-idx tmp-name flag-name flag-idx)
;; ── STEP 9 ──
;; Same lane-0-cswap-preserved policy as STEP 3 — see above.
(cswap-reg! c a-f 0 u-name v-w-name uv-w)
(cswap-reg! c a-f 0 r-name s-name rs9-w)
;; ── STEP 10 ──
(gate-x! c s-name 0)
(gate-ccx! c f-name f-idx s-name 0 a-f 0)
(gate-x! c s-name 0)
(free! c l-gt)
(free! c add-f)
(free! c b-f)
(free! c a-f)))
;;; ── mod-inv-by-dialog-gcd! — top-level entry ─────────────────────
;;; Same calling convention as mod-inv-by-refined!. The classical-
;;; replay backward sweep handles the cap-aware uncompute.
;;;
;;; CRITICAL: classical-kaliski-r-final and classical-kaliski-trace
;;; are parameterized by `iters`. We pass the resolved
;;; *dgcd-active-iters* cap so the K-correction and final-state
;;; reset match the capped quantum forward sweep.
(define (mod-inv-by-dialog-gcd! c a-reg out-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx
red-tmp-reg)
"out := a^{-1} mod p via Kaliski under HEAD's DIALOG_GCD lever.
Same calling convention as mod-inv-by-refined!. REQUIRES a-reg
bound via bind-input!/bind-mirror!. *dgcd-active-iters* may cap
below 2n; correctness gate runs at build time."
(let* ((n (- n+1 1))
(iters (dgcd-resolve-iters n+1))
(u 'kal-u)
(v-w 'kal-v-w)
(r 'kal-r)
(s 'kal-s)
(f 'kal-f)
(m-hist 'kal-m-hist)
(mc-tmp 'kal-mc-tmp)
(mc-pow 'kal-mc-pow)
(a-mask 'kal-a-masked)
(a-bound (find-classical-value c a-reg)))
(cond
((<= n 0)
(error "mod-inv-by-dialog-gcd! requires n+1 > 1; got" n+1))
;; *static-circuit-mode*: under K=1, K-correction here is
;; `a`-independent (same as mod-inv-by-dialog-gcd-host! above).
;; K=2 is gated to host-only at the next branch — no need to
;; duplicate the static-mode + K=2 incompatibility check.
((and (not a-bound)
(not *static-circuit-mode*))
(error "mod-inv-by-dialog-gcd! requires a-reg classical via"
" bind-input!/bind-mirror!; not found:" a-reg))
(*dgcd-k2-bounded-shift*
;; sweep-k2-port: K=2 bounded shift only ported into the host
;; variant. Non-host classical-replay's final-* values reflect
;; K=2 forward — but non-host quantum forward sweep does K=1 —
;; so the backward sweep would reset to WRONG state. Refuse to
;; emit instead of producing a silently-broken .bin. Use the
;; host variant (mod-inv-by-dialog-gcd-host!) for K=2.
(error "*dgcd-k2-bounded-shift* requires HOST_GATED variant. "
"Set *dgcd-host-gated* and use mod-inv-by-dialog-gcd-host!"))
(else
;; ── Build-time correctness gate: K from a=1 trace must invert ──
;; r_on_1 (at the capped iter count) the SAME way it does at 2n.
;; If the cap is too aggressive r_on_1 may be 0 (no inverse), in
;; which case we error before emitting any gates.
(let ((r-on-1 (classical-kaliski-r-final 1 p iters n+1)))
(when (= (modulo r-on-1 p) 0)
(error "mod-inv-by-dialog-gcd! *dgcd-active-iters* too low: "
"r_on_1 mod p = 0 at iters=" iters
" n+1=" n+1 " p=" p)))
;; ── ODD_U soundness gate ──
;; The body fastpath (skip-lane-0 of mask compute + body, with
;; cx(add_f, v_w[0]) compensation) is structurally sound on
;; our substrate: from the classical kaliski-iteration-trunc!
;; trace, add_f=1 occurs ⇔ both u and v_w are odd at the
;; body call site (proof: add_f4 = f AND NOT b_f1; b_f1=0
;; only when both u, v_w odd). When add_f=1, v_w[0]-u[0] =
;; 1-1 = 0 with no borrow into bit 1 — value-exact lane-0
;; replacement. The CSWAP lane 0 is NOT skipped (our cswap
;; controller a_f fires in u[0]=0,v_w[0]=1 cases where
;; lane-0 swap is not identity). HEAD's cswap-skip relies
;; on its b0_and_b1 controller which differs from a_f.
;; ── Allocate Kaliski state ──
(alloc! c u n+1)
(alloc! c v-w n+1)
(alloc! c r n+1)
(alloc! c s n+1)
(alloc! c f 1)
(alloc! c m-hist iters)
(alloc! c a-mask n+1)
;; ── Init ──
(load-const! c u n+1 p)
(cx-copy-reg! c a-reg v-w n+1)
(gate-x! c s 0)
(gate-x! c f 0)
;; ── Forward sweep (D1 + D2 + D3) ──
(let loop ((i 0))
(when (< i iters)
(kaliski-iteration-dgcd! c i n+1 p
u v-w r s
f 0
m-hist i
cin-reg cin-idx
tmp-reg flag-reg flag-idx
red-tmp-reg
a-mask)
(loop (+ i 1))))
;; ── Classical correction K at the capped iter count ──
(let* ((r-on-1 (classical-kaliski-r-final 1 p iters n+1))
(k-correct (classical-mod-inv p r-on-1))
(k-inverse r-on-1))
(in-place-mul-const! c r n+1 p k-correct
cin-reg cin-idx tmp-reg flag-reg flag-idx
red-tmp-reg
mc-tmp mc-pow)
(cx-copy-reg! c r out-reg n+1)
(in-place-mul-const! c r n+1 p k-inverse
cin-reg cin-idx tmp-reg flag-reg flag-idx
red-tmp-reg
mc-tmp mc-pow))
;; ── Classical-replay backward sweep (capped trace) ──
(let* ((trace (classical-kaliski-trace a-bound p iters n+1))
(final-u (car trace))
(final-v-w (car (cdr trace)))
(final-r (car (cdr (cdr trace))))
(final-s (car (cdr (cdr (cdr trace)))))
(final-f (car (cdr (cdr (cdr (cdr trace))))))
(m-i-vec (car (cdr (cdr (cdr (cdr (cdr trace))))))))
(classical-reset! c u n+1 final-u)
(classical-reset! c v-w n+1 final-v-w)
(classical-reset! c r n+1 final-r)
(classical-reset! c s n+1 final-s)
(when (= final-f 1) (gate-x! c f 0))
(let loop ((i 0))
(when (< i iters)
(when (= (vector-ref m-i-vec i) 1)
(gate-x! c m-hist i))
(loop (+ i 1)))))
;; ── Free Kaliski state ──
(free! c a-mask)
(free! c m-hist)
(free! c f)
(free! c s)
(free! c r)
(free! c v-w)
(free! c u)))))
;;; ── public-name dispatch from mod-inv-by! is NOT done here ───────
;;;
;;; To keep this lever isolated from karatsuba-agent's concurrent
;;; work on mod-inv-by.lsp / variants-real.lsp, the variant entry in
;;; sweep-005 calls mod-inv-by-dialog-gcd! DIRECTLY via a thin
;;; builder. See variants-real.lsp's v-by-dialog-gcd-solinas (added
;;; in this file's load order so existing variants stay untouched).
Reference in a new issue View git blame Copy permalink