;;; mod-arith.lsp — reversible modular arithmetic over a generic prime.
;;;
;;; Public surface: bit-set?, load-const!, unload-const!, cload-const!,
;;; cunload-const!, add-const!, csub-const!, inv-maj!, cmp-lt-into!,
;;; mod-add!, mod-sub!, mod-mul!, mod-double-inplace!, mod-halve-inplace!,
;;; mod-shift-left/right-by-k-lowq!, mod-add-qb!, mod-sub-qb!. Layer
;;; sits on adder.lsp (Cuccaro ripple-carry).
;;;
;;; mod-add CALLING CONVENTION: caller passes a-reg & acc-reg as
;;; (n+1)-wide registers, top bit held at |0> (extension ancilla).
;;; Caller also allocates cin (1 bit), tmp (n+1 bits), flag (1 bit).
;;; All ancillae return to |0>; top bit of a-reg & acc-reg also returns
;;; to |0> on exit.
;;;
;;; ── *field-prime* convention ─────────────────────────────────────
;;;
;;; Primitives take `p` as explicit argument (p = field prime, integer).
;;; New upstream consumers can ALSO set `*field-prime*` at program top
;;; so layer code reads a single source of truth & avoids threading p
;;; through every wrapper. Foxhop callers still pass p directly.
;;;
;;; Public mod-* primitives assert *field-prime* matches their `p` arg
;;; if both are set, otherwise accept caller's `p` as authoritative.

(define *field-prime* #f)
;; Consumer binds via (set! *field-prime* <p>) before calling mod-arith
;; primitives. Stays #f when not used; primitives derive width from
;; (bit-length p) or accept width via caller arg.

(load "quantum/gates.lsp")
(load "quantum/adder.lsp")

;;; ── classical-constant load/unload ─────────────────────────────

(define (bit-set? k i)
  "Is bit i (0-indexed) set in classical integer k?"
  (= 1 (remainder (quotient k (expt 2 i)) 2)))

(define (load-const! c reg n k)
  "Apply X to reg[i] for every i in [0,n) where bit i of k is 1.
   reg starts |0> n-wide; ends holding the bit pattern of k mod 2^n."
  (let loop ((i 0))
    (when (< i n)
      (when (bit-set? k i) (gate-x! c reg i))
      (loop (+ i 1)))))

(define (unload-const! c reg n k) (load-const! c reg n k))

(define (cload-const! c ctrl-reg ctrl-idx tgt-reg n k)
  "Apply CX(ctrl, tgt[i]) for every i where bit i of k is 1."
  (let loop ((i 0))
    (when (< i n)
      (when (bit-set? k i) (gate-cx! c ctrl-reg ctrl-idx tgt-reg i))
      (loop (+ i 1)))))

(define (cunload-const! c ctrl-reg ctrl-idx tgt-reg n k)
  (cload-const! c ctrl-reg ctrl-idx tgt-reg n k))

;;; ── extcarry_clean family — sweep-extcarry-clean ──────────────────
;;;
;;; HEAD const_arith.rs:239,251,274,289,317,331. Closes AUDIT §6
;;; rows 208-212.
;;;
;;; Pattern (HEAD lines 257-269 + symmetric): each primitive
;;;   1. load const c into `ca` register (cx-from-ctrl for controlled
;;;      variants, x for uncontrolled)
;;;   2. cuccaro-add/sub-low-to-ext-clean! with cin
;;;   3. unload (same op-stream self-inverse)
;;;
;;; HEAD's `borrow_cin: Option<QubitId>` switches between caller-
;;; supplied vs fresh-alloc cin. Lumbda is caller-allocated throughout;
;;; cin-reg + cin-idx are mandatory caller-supplied parameters. The
;;; six HEAD names collapse to a smaller surface in lumbda but we keep
;;; all six for ABI parity — callers may want to name the "borrow"
;;; variant explicitly even though the wire pattern is identical.
;;;
;;; Caller responsibility:
;;;   - acc-ext-reg width >= n+1 (n data bits + 1 ext carry bit)
;;;   - ca-reg width >= n (clean |0> on entry; restored on exit)
;;;   - cin-reg[cin-idx] = |0> on entry; restored on exit
;;;   - ctrl-reg[ctrl-idx] (controlled variants) — read-only

(define (add-nbit-const-extcarry-clean!
          c acc-ext-reg n k ca-reg cin-reg cin-idx)
  "Port of HEAD add_nbit_const_extcarry_clean (const_arith.rs:239).
   acc-ext-reg := (acc-ext-reg + k) mod 2^(n+1), carry into top bit."
  (load-const! c ca-reg n k)
  (cuccaro-add-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx)
  (unload-const! c ca-reg n k))

(define (add-nbit-const-extcarry-clean-with-cin!
          c acc-ext-reg n k ca-reg cin-reg cin-idx)
  "Port of HEAD add_nbit_const_extcarry_clean_with_cin
   (const_arith.rs:251). Wire-identical to the non-with-cin variant
   in lumbda since cin is always caller-supplied; preserves HEAD's
   ABI name for callers that explicitly borrow cin from a live-idle
   lane (round84-lowq mid-sub uses this naming)."
  (add-nbit-const-extcarry-clean!
    c acc-ext-reg n k ca-reg cin-reg cin-idx))

(define (sub-nbit-const-extcarry-clean!
          c acc-ext-reg n k ca-reg cin-reg cin-idx)
  "Port of HEAD sub_nbit_const_extcarry_clean (const_arith.rs:274).
   acc-ext-reg := (acc-ext-reg - k) mod 2^(n+1), borrow into top bit."
  (load-const! c ca-reg n k)
  (cuccaro-sub-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx)
  (unload-const! c ca-reg n k))

(define (cadd-nbit-const-extcarry-clean!
          c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx)
  "Port of HEAD cadd_nbit_const_extcarry_clean (const_arith.rs:289).
   acc-ext-reg += (ctrl ? k : 0), carry into top bit. Drop-in for
   cadd-nbit-const. Constant loaded via CX-from-ctrl so the
   unconditional clean adder realizes the controlled add."
  (cload-const! c ctrl-reg ctrl-idx ca-reg n k)
  (cuccaro-add-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx)
  (cunload-const! c ctrl-reg ctrl-idx ca-reg n k))

(define (csub-nbit-const-extcarry-clean!
          c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx)
  "Port of HEAD csub_nbit_const_extcarry_clean (const_arith.rs:317).
   acc-ext-reg -= (ctrl ? k : 0), borrow into top bit."
  (cload-const! c ctrl-reg ctrl-idx ca-reg n k)
  (cuccaro-sub-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx)
  (cunload-const! c ctrl-reg ctrl-idx ca-reg n k))

(define (csub-nbit-const-extcarry-clean-with-cin!
          c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx)
  "Port of HEAD csub_nbit_const_extcarry_clean_with_cin
   (const_arith.rs:331). Wire-identical to csub-nbit-const-extcarry-
   clean! in lumbda; ABI alias for explicit-borrow callers (the
   peak-binding round84-lowq mid-sub borrows c_in from idle a_ovf
   lane to drop peak 1308 -> 1307)."
  (csub-nbit-const-extcarry-clean!
    c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx))

;;; ── add/sub of classical constant ──────────────────────────────

(define (add-const! c acc-reg n k cin-reg cin-idx tmp-reg)
  "acc := (acc + k) mod 2^n. tmp must be a width-n register at |0>."
  (let ((kk (modulo k (expt 2 n))))
    (load-const!   c tmp-reg n kk)
    (cuccaro-add!  c tmp-reg acc-reg cin-reg cin-idx n)
    (unload-const! c tmp-reg n kk)))

(define (csub-const! c acc-reg n k ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg)
  "acc -= (ctrl ? k : 0) mod 2^n. Dispatches to direct sparse path when
   *cadd-direct-trunc-fast* on; else cload + cuccaro-sub + cunload."
  (let ((kk (modulo k (expt 2 n))))
    (cond
      ((and *cadd-direct-trunc-fast* (> n 1) (> kk 0))
       (csub-nbit-const-direct-trunc-fast!
         c acc-reg n kk ctrl-reg ctrl-idx tmp-reg
         *cadd-direct-window* (cdtf-alloc-bit-base! n)))
      (else
       (cload-const!  c ctrl-reg ctrl-idx tmp-reg n kk)
       ;; sub = inverse of add. cuccaro-add (a, acc) is a bijection; we
       ;; manually invert by emitting the gates in reverse. Implemented as
       ;; cuccaro-sub! below.
       (cuccaro-sub!  c tmp-reg acc-reg cin-reg cin-idx n)
       (cunload-const! c ctrl-reg ctrl-idx tmp-reg n kk)))))

;;; ── Cuccaro sub (inverse of cuccaro-add) ───────────────────────

(define (cuccaro-sub! c a-reg acc-reg cin-reg cin-idx n)
  "acc := (acc - a) mod 2^n. Inverse of cuccaro-add gate-by-gate."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c a-reg   0       acc-reg 0)
     (gate-cx! c cin-reg cin-idx acc-reg 0))
    (else
     ;; Inverse of cuccaro-add:
     ;;   inv-uma at i=0
     ;;   inv-uma for i in 1..n-2
     ;;   inv of final CX pair (cx is its own inverse, so same gates reversed)
     ;;   inv-maj for i in n-2..1 (descending in fwd; so ascending in inv)
     ;;   inv-maj at top (c-in,acc[0],a[0])
     ;;
     ;; UMA(x,y,w): (ccx x y w)(cx w x)(cx x y)
     ;; inv-UMA = (cx x y)(cx w x)(ccx x y w)
     ;; MAJ(x,y,w): (cx w y)(cx w x)(ccx x y w)
     ;; inv-MAJ = (ccx x y w)(cx w x)(cx w y)
     ;;
     ;; Walking forward gates in reverse order:
     ;;   final uma(cin,acc[0],a[0])              -> inv-uma at start
     ;;   for i in 1..n-2 (forward order in inverse: that's the rev loop)
     ;;     uma(a[i-1], acc[i], a[i])
     ;;   reverse of "cx a[n-1] acc[n-1]; cx a[n-2] acc[n-1]" is same two CX
     ;;   reverse of MAJ sweep
     (inv-uma! c cin-reg cin-idx acc-reg 0 a-reg 0)
     (let loop ((i 1))
       (when (< i (- n 1))
         (inv-uma! c a-reg (- i 1) acc-reg i a-reg i)
         (loop (+ i 1))))
     (gate-cx! c a-reg (- n 1) acc-reg (- n 1))
     (gate-cx! c a-reg (- n 2) acc-reg (- n 1))
     (let loop ((i (- n 2)))
       (when (>= i 1)
         (inv-maj! c a-reg (- i 1) acc-reg i a-reg i)
         (loop (- i 1))))
     (inv-maj! c cin-reg cin-idx acc-reg 0 a-reg 0))))

(define (inv-uma! c x-reg x-idx y-reg y-idx w-reg w-idx)
  "Inverse of uma!: (cx x y) (cx w x) (ccx x y w)."
  (gate-cx!  c x-reg x-idx y-reg y-idx)
  (gate-cx!  c w-reg w-idx x-reg x-idx)
  (gate-ccx! c x-reg x-idx y-reg y-idx w-reg w-idx))

(define (inv-maj! c x-reg x-idx y-reg y-idx w-reg w-idx)
  "Inverse of maj!: (ccx x y w) (cx w x) (cx w y)."
  (gate-ccx! c x-reg x-idx y-reg y-idx w-reg w-idx)
  (gate-cx!  c w-reg w-idx x-reg x-idx)
  (gate-cx!  c w-reg w-idx y-reg y-idx))

;;; ── n-bit comparison: flag := flag XOR (u < v) ─────────────────

(define (cmp-lt-into! c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx)
  "flag ^= (u < v). u and v are width-n quantum registers; restored.
   cin starts |0> ends |0>."
  ;; Negate u
  (let loop ((i 0))
    (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
  ;; Forward MAJ sweep — n MAJs (includes the top one)
  (maj! c cin-reg cin-idx v-reg 0 u-reg 0)
  (let loop ((i 1))
    (when (< i n)
      (maj! c u-reg (- i 1) v-reg i u-reg i)
      (loop (+ i 1))))
  ;; CX top -> flag
  (gate-cx! c u-reg (- n 1) flag-reg flag-idx)
  ;; Inverse MAJ sweep
  (let loop ((i (- n 1)))
    (when (>= i 1)
      (inv-maj! c u-reg (- i 1) v-reg i u-reg i)
      (loop (- i 1))))
  (inv-maj! c cin-reg cin-idx v-reg 0 u-reg 0)
  ;; Un-negate u
  (let loop ((i 0))
    (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))))

;;; cmp-lt-into-fast! — HEAD's cmp_lt_into_fast (mod.rs:3643-3693)
;;; HMR-uncompute variant of cmp-lt-into!. Same flag semantics but
;;; carries lane borrowed from caller + HMR backward sweep saves n
;;; Toffoli per call.

(define (cmp-lt-into-fast! c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx
                           carries-reg carries-offset bit-base)
  "flag ^= (u < v). Same semantics as cmp-lt-into! but with HMR carry
   uncompute. carries-reg[carries-offset..carries-offset+n-1] must be
   |0> on entry; HMR returns them to |0> on exit.
   bit-base..bit-base+n-1 used for classical bits."
  (cond
    ((= n 0) #t)
    (else
     ;; Negate u
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
     ;; Forward sweep — n MAJ-style with explicit carries
     (gate-cx!  c u-reg 0 v-reg 0)
     (gate-cx!  c u-reg 0 cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx v-reg 0 carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset u-reg 0)
     (let loop ((i 1))
       (when (< i n)
         (gate-cx!  c u-reg i v-reg i)
         (gate-cx!  c u-reg i u-reg (- i 1))
         (gate-ccx! c u-reg (- i 1) v-reg i carries-reg (+ carries-offset i))
         (gate-cx!  c carries-reg (+ carries-offset i) u-reg i)
         (loop (+ i 1))))
     ;; CX top carry -> flag
     (gate-cx! c u-reg (- n 1) flag-reg flag-idx)
     ;; Backward HMR uncompute sweep
     (let loop-back ((i (- n 1)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i) u-reg i)
         (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c u-reg (- i 1) v-reg i)
         (gate-pop-cond!   c)
         (gate-cx!         c u-reg i u-reg (- i 1))
         (gate-cx!         c u-reg i v-reg i)
         (loop-back (- i 1))))
     ;; Step 0 backward
     (gate-cx!         c carries-reg carries-offset u-reg 0)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx v-reg 0)
     (gate-pop-cond!   c)
     (gate-cx!         c u-reg 0 cin-reg cin-idx)
     (gate-cx!         c u-reg 0 v-reg 0)
     ;; Un-negate u
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))))))

;;; ── ccx-cmp-lt-into-fast! / cmp-lt-into-fast-with-cin! / phase-conditioned variants
;;;
;;; HEAD compare.rs:55,108,330,357. Closes AUDIT §7 rows 184-185 + 186-187
;;; (compare.rs no-prefix-targets siblings).
;;;
;;; ──── cmp-lt-into-fast-with-cin! — ABI alias ────
;;; HEAD's cmp_lt_into_fast_with_cin (compare.rs:55) is wire-identical
;;; to cmp_lt_into_fast except c_in is caller-supplied instead of
;;; freshly-allocated. Lumbda's cmp-lt-into-fast! is ALREADY the
;;; with-cin form (caller passes cin-reg + cin-idx). This alias names
;;; the variant for callers that explicitly borrow c_in from a live-
;;; idle lane.

(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)
  "Port of HEAD cmp_lt_into_fast_with_cin (compare.rs:55). Wire-
   identical to cmp-lt-into-fast! in lumbda; ABI alias for explicit-
   borrow callers."
  (cmp-lt-into-fast!
    c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx
    carries-reg carries-offset bit-base))

;;; ──── ccx-cmp-lt-into-fast! — without prefix-targets ────
;;; HEAD compare.rs:108. Identical to cmp_lt_into_fast but replaces
;;; cx(u[n-1], flag) with ccx(ctrl, u[n-1], target). All other gates
;;; mirror cmp-lt-into-fast! verbatim.

(define (ccx-cmp-lt-into-fast!
          c u-reg v-reg n ctrl-reg ctrl-idx target-reg target-idx
          cin-reg cin-idx carries-reg carries-offset bit-base)
  "Port of HEAD ccx_cmp_lt_into_fast (compare.rs:108). target ^=
   (ctrl AND (u < v)). Same Gidney measurement-UMA pattern as
   cmp-lt-into-fast! with the middle CX replaced by CCX."
  (cond
    ((= n 0) #t)
    (else
     ;; Negate u
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
     ;; Forward sweep
     (gate-cx!  c u-reg 0 v-reg 0)
     (gate-cx!  c u-reg 0 cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx v-reg 0 carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset u-reg 0)
     (let loop ((i 1))
       (when (< i n)
         (gate-cx!  c u-reg i v-reg i)
         (gate-cx!  c u-reg i u-reg (- i 1))
         (gate-ccx! c u-reg (- i 1) v-reg i carries-reg (+ carries-offset i))
         (gate-cx!  c carries-reg (+ carries-offset i) u-reg i)
         (loop (+ i 1))))
     ;; CCX top carry -> target (only diff vs cmp-lt-into-fast!)
     (gate-ccx! c ctrl-reg ctrl-idx u-reg (- n 1) target-reg target-idx)
     ;; Backward HMR uncompute sweep
     (let loop-back ((i (- n 1)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i) u-reg i)
         (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c u-reg (- i 1) v-reg i)
         (gate-pop-cond!   c)
         (gate-cx!         c u-reg i u-reg (- i 1))
         (gate-cx!         c u-reg i v-reg i)
         (loop-back (- i 1))))
     (gate-cx!         c carries-reg carries-offset u-reg 0)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx v-reg 0)
     (gate-pop-cond!   c)
     (gate-cx!         c u-reg 0 cin-reg cin-idx)
     (gate-cx!         c u-reg 0 v-reg 0)
     ;; Un-negate u
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))))))

;;; ──── cmp-lt-phase-conditioned! / -borrowed-carries! ────
;;; HEAD compare.rs:357 / 330. Phase-conditioned comparator variants.
;;; Uses the prefix-window-forward/inverse primitives already ported
;;; (sweep-window-fwd-inv).
;;;
;;; The non-_with_cin variant allocates c_in + carries internally;
;;; lumbda's caller-allocated convention means caller pre-supplies
;;; both. The borrowed-carries variant takes carries from caller.

(define (cmp-lt-phase-conditioned!
          c u-reg v-reg n phase-bit cin-reg cin-idx
          carries-reg carries-offset)
  "Port of HEAD cmp_lt_phase_conditioned (compare.rs:357). Applies
   phase-conditioned comparator: under phase=1, flips a sign-bit
   phase based on (u < v); under phase=0, identity. Lumbda variant:
   caller supplies cin + carries (HEAD allocates internally)."
  (gate-push-cond! c phase-bit)
  ;; Negate u
  (let loop ((i 0))
    (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
  ;; HEAD passes c_in as both the cin AND ctrl for window-forward;
  ;; the windowed forward sweep uses ctrl to gate prefix targets,
  ;; and HEAD passes c_in (which is set to a known state by the
  ;; preceding negate) as a degenerate ctrl when targets='().
  (cmp-lt-fast-prefix-window-forward!
    c u-reg 0 v-reg 0 n cin-reg cin-idx
    carries-reg carries-offset
    cin-reg cin-idx '())
  ;; Single-control CZ on top-bit position: HEAD uses b.cz(u[n-1], u[n-1])
  ;; which classically degenerates to a sign-bit phase. Lumbda gate-cz!
  ;; with same reg+idx is the same op.
  (gate-cz! c u-reg (- n 1) u-reg (- n 1))
  (cmp-lt-fast-prefix-window-inverse!
    c u-reg 0 v-reg 0 n cin-reg cin-idx
    carries-reg carries-offset)
  ;; Un-negate u
  (let loop ((i 0))
    (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
  (gate-pop-cond! c))

(define (cmp-lt-phase-conditioned-borrowed-carries!
          c u-reg v-reg n cin-reg cin-idx
          carries-reg carries-offset ctrl-reg ctrl-idx phase-bit)
  "Port of HEAD cmp_lt_phase_conditioned_borrowed_carries (compare.rs:330).
   Same as cmp-lt-phase-conditioned! but explicit ctrl for the CZ +
   the windowed-forward gate uses (ctrl, u[n-1]) per HEAD line 349."
  (gate-push-cond! c phase-bit)
  (let loop ((i 0))
    (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
  (cmp-lt-fast-prefix-window-forward!
    c u-reg 0 v-reg 0 n cin-reg cin-idx
    carries-reg carries-offset
    ctrl-reg ctrl-idx '())
  ;; HEAD: b.cz(ctrl, u[n-1])
  (gate-cz! c ctrl-reg ctrl-idx u-reg (- n 1))
  (cmp-lt-fast-prefix-window-inverse!
    c u-reg 0 v-reg 0 n cin-reg cin-idx
    carries-reg carries-offset)
  (let loop ((i 0))
    (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
  (gate-pop-cond! c))

;;; ── ccx-cmp-lt-into-fast-prefix-targets! ──────────────────────────
;;;
;;; Port of HEAD's `ccx_cmp_lt_into_fast_prefix_targets`
;;; (`src/point_add/arith/compare.rs:161-232`, commit 2dcf00d). Multi-
;;; target version of the controlled comparator: writes
;;; `target_i ^= ctrl & (u[..n_i] < v[..n_i])` for every (target_i,
;;; n_i) in `targets`. Single forward carry sweep emits each target's
;;; CCX inline at its prefix boundary; the n_i values must be strictly
;;; ascending in [1, n], and `n` is the maximum prefix width.
;;;
;;; Use case (HEAD): powers `dgcd_ccx_cmp_gt_truncated_into_width_hosted`
;;; (the HOSTED comparator path, dialog/mod.rs:83). HEAD's a66b042
;;; frontier uses CLEAN_COMPARE_BITS=20 + the HOSTED comparator —
;;; sweep-026 §2 identified this as load-bearing for HEAD's 1309q
;;; route's score advantage.
;;;
;;; Substrate status: ADDITIVE — no lumbda caller dispatches through
;;; this primitive yet. Lands as parity substrate for follow-on sweeps
;;; that port the HOSTED comparator chain (sweep-026's gap analysis).
;;;
;;; Signature mirrors HEAD's argument order:
;;;   c              — circuit handle.
;;;   u-reg v-reg    — quantum registers of width >= n. Compared bitwise.
;;;   n              — maximum prefix width (= largest target prefix-width).
;;;   ctrl-reg ctrl-idx — control qubit; comparator only writes when ctrl is |1>.
;;;   targets        — list of (target-reg target-idx prefix-width) triples.
;;;                    Strictly ascending prefix-widths, each in [1, n].
;;;                    Empty list is a clean no-op (HEAD line 168-170).
;;;   carries-reg carries-offset — borrowed |0>-on-entry carries lane
;;;                    of width >= n. Returned to |0> on exit via HMR.
;;;   cin-reg cin-idx — borrowed |0> ancilla; restored on exit.
;;;   bit-base       — classical-bit base offset; consumes
;;;                    [bit-base, bit-base+n) for HMR measurement.
;;;
;;; Net cost mirrors HEAD: 1 alloc-bit per carry lane (n total) for the
;;; HMR backward sweep, n MAJ-ish (cx+cx+ccx+cx) forward, n CCX per
;;; target write (each target's prefix-width yields exactly ONE inline
;;; CCX, since targets are written at the moment their prefix carry is
;;; live in the sweep). Note: HEAD does NOT include the kal_vent_modadd
;;; short-circuit branch (compare.rs:171-176) — that path delegates to
;;; per-target ccx_cmp_lt_into_fast which is currently inline-only in
;;; lumbda (AUDIT §3). Adding it later is additive + flag-gated.

(define (ccx-cmp-lt-into-fast-prefix-targets!
         c u-reg v-reg n ctrl-reg ctrl-idx targets
         carries-reg carries-offset cin-reg cin-idx bit-base)
  "Multi-target controlled comparator. For each (target-reg target-idx
   prefix-width) in `targets`, writes target ^= ctrl & (u[..prefix-width]
   < v[..prefix-width]). Targets MUST have strictly ascending
   prefix-widths each in [1, n]. Returns carries-reg + cin-reg to |0>
   via HMR uncompute."
  (cond
    ;; Clean no-op on empty target list (HEAD compare.rs:168-170).
    ((null? targets) #t)
    ((= n 0) #t)
    (else
     ;; Step 1: negate u. Mirrors HEAD's `for &q in u { b.x(q); }`.
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
     ;; Step 2: forward carry sweep with inline target writes.
     ;; First slot (i=0) mirrors HEAD compare.rs:191-199.
     (gate-cx!  c u-reg 0 v-reg 0)
     (gate-cx!  c u-reg 0 cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx v-reg 0 carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset u-reg 0)
     ;; Walk targets in step with the forward sweep. `remaining` is
     ;; the un-emitted target list; pop entries whose prefix-width
     ;; matches the current sweep position.
     (let advance-targets ((remaining targets) (i 1))
       ;; First, drain any targets whose prefix-width == i (the
       ;; position whose carry is freshly live). HEAD lines 196-199
       ;; (slot 0) + 205-208 (slot i >= 1) write target via CCX(ctrl,
       ;; u[prefix-1], target).
       (cond
         ((and (not (null? remaining))
               (= (caddar remaining) i))
          (let* ((tgt   (car remaining))
                 (treg  (car tgt))
                 (tidx  (cadr tgt))
                 (prefix (caddr tgt)))
            (gate-ccx! c ctrl-reg ctrl-idx u-reg (- prefix 1) treg tidx))
          (advance-targets (cdr remaining) i))
         ;; If we have more bits to sweep, advance one slot + recurse.
         ((< i n)
          (gate-cx!  c u-reg i v-reg i)
          (gate-cx!  c u-reg i u-reg (- i 1))
          (gate-ccx! c u-reg (- i 1) v-reg i carries-reg (+ carries-offset i))
          (gate-cx!  c carries-reg (+ carries-offset i) u-reg i)
          (advance-targets remaining (+ i 1)))
         ;; Sweep done. Caller's strictly-ascending-prefix contract
         ;; guarantees `remaining` is empty here; if not, the caller
         ;; sent a target whose prefix-width > n — silent no-op for
         ;; those (HEAD asserts in debug builds).
         (else #t)))
     ;; Step 3: backward HMR uncompute. Identical shape to
     ;; cmp-lt-into-fast!'s backward sweep (HEAD compare.rs:212-225).
     (let loop-back ((i (- n 1)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i) u-reg i)
         (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c u-reg (- i 1) v-reg i)
         (gate-pop-cond!   c)
         (gate-cx!         c u-reg i u-reg (- i 1))
         (gate-cx!         c u-reg i v-reg i)
         (loop-back (- i 1))))
     ;; Step 0 backward.
     (gate-cx!         c carries-reg carries-offset u-reg 0)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx v-reg 0)
     (gate-pop-cond!   c)
     (gate-cx!         c u-reg 0 cin-reg cin-idx)
     (gate-cx!         c u-reg 0 v-reg 0)
     ;; Un-negate u.
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))))))

;;; ── ccx-cmp-lt-into-fast-borrowed-carries! ────────────────────────
;;;
;;; Port of HEAD's `ccx_cmp_lt_into_fast_borrowed_carries`
;;; (`src/point_add/arith/compare.rs:561-612`, commit 2dcf00d). Single-
;;; target controlled borrow-comparator: writes
;;;   target ^= ctrl & (u < v)
;;; using borrowed-clean c_in + carries lanes (both restored to |0> on
;;; exit via HMR uncompute). HEAD's docstring at compare.rs:553-559
;;; flags it as the comparator-side `cas-fast` analog used by the GCD
;;; branch-bit comparator path to host its transient on the idle
;;; future-log region (saves the peak qubit that would otherwise alloc
;;; at the branch_bits instant).
;;;
;;; Implementation: thin wrapper over `ccx-cmp-lt-into-fast-prefix-targets!`
;;; with a single-element targets list = `((target-reg target-idx n))`.
;;; HEAD's standalone-function form (compare.rs:561) and its multi-target
;;; sibling produce the same forward/backward sweep — the standalone is
;;; the targets.len()==1 case at the full-width prefix. Wrapping over the
;;; just-ported prefix-targets! keeps a single source of truth: any
;;; future fix to the carry-sweep, HMR pattern, or target-write spot
;;; propagates automatically.
;;;
;;; Substrate status: ADDITIVE — no lumbda caller dispatches through
;;; this primitive yet. Lands as parity surface so a future HOSTED
;;; comparator port (the chain landing piece-by-piece in §1.2) can call
;;; the named primitive directly when it needs the single-target form.

(define (ccx-cmp-lt-into-fast-borrowed-carries!
         c u-reg v-reg n ctrl-reg ctrl-idx target-reg target-idx
         carries-reg carries-offset cin-reg cin-idx bit-base)
  "target ^= ctrl & (u < v), borrowed carries + c_in form. See header
   comment. n=0 is a clean no-op (mirrors prefix-targets!'s n=0 path)."
  (ccx-cmp-lt-into-fast-prefix-targets!
    c u-reg v-reg n ctrl-reg ctrl-idx
    (list (list target-reg target-idx n))
    carries-reg carries-offset cin-reg cin-idx bit-base))

;;; ── ccx-cmp-lt-into-fast-borrowed-carries-offset! ─────────────────
;;;
;;; Offset-indexed variant of `ccx-cmp-lt-into-fast-borrowed-carries!`
;;; — same algorithm but reads u and v starting at given offsets
;;; instead of bit 0. Mirrors HEAD compare.rs:561 the way our
;;; cmp-lt-into-fast-offset! mirrors cmp-lt-into-fast! (one offset
;;; parameter per register).
;;;
;;; Use case: HEAD's HOSTED comparator (dialog/mod.rs:83) slices its
;;; input via `&u[start..]; &v[start..]` where start = active_width -
;;; compare_bits. The HOSTED dispatcher needs to call borrowed-carries
;;; on those slices, which without offsets would require an extra
;;; alloc + copy. The offset variant lets HOSTED call directly with
;;; (u-reg, start, ...) avoiding the per-call ancilla.
;;;
;;; Substrate status: ADDITIVE. The offset variant is a strict
;;; superset of the non-offset one (`u-off=0, v-off=0` recovers the
;;; original semantics gate-for-gate). Existing `ccx-cmp-lt-into-fast-
;;; borrowed-carries!` callers (none yet) remain untouched.
;;;
;;; Implementation: forward sweep mirrors HEAD compare.rs:563-595 with
;;; offsets threaded through every gate-cx! / gate-ccx! call; backward
;;; HMR uncompute mirrors compare.rs:597-611 similarly. Both halves
;;; identical to the non-offset variant when u-off=v-off=0.

(define (ccx-cmp-lt-into-fast-borrowed-carries-offset!
         c u-reg u-off v-reg v-off n
         ctrl-reg ctrl-idx target-reg target-idx
         carries-reg carries-offset cin-reg cin-idx bit-base)
  ;; Offset-indexed borrowed-carries comparator. n=0 is a no-op.
  ;; All offsets in [0, register-width-n]; caller guarantees.
  (cond
    ((= n 0) #t)
    (else
     ;; Negate u slice (in place).
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))
     ;; Forward sweep with target write at the n-th boundary.
     (gate-cx!  c u-reg u-off v-reg v-off)
     (gate-cx!  c u-reg u-off cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx v-reg v-off carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset u-reg u-off)
     (cond
       ((= n 1)
        ;; Single-bit: write target at prefix=1.
        (gate-ccx! c ctrl-reg ctrl-idx u-reg u-off target-reg target-idx))
       (else
        (let loop ((i 1))
          (when (< i n)
            (gate-cx!  c u-reg (+ u-off i) v-reg (+ v-off i))
            (gate-cx!  c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
            (gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)
                         carries-reg (+ carries-offset i))
            (gate-cx!  c carries-reg (+ carries-offset i) u-reg (+ u-off i))
            (loop (+ i 1))))
        ;; Target write at prefix=n: ccx(ctrl, u[u-off + n - 1], target).
        (gate-ccx! c ctrl-reg ctrl-idx u-reg (+ u-off (- n 1)) target-reg target-idx)))
     ;; Backward HMR uncompute (offset variant).
     (let loop-back ((i (- n 1)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i) u-reg (+ u-off i))
         (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c u-reg (+ u-off (- i 1)) v-reg (+ v-off i))
         (gate-pop-cond!   c)
         (gate-cx!         c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
         (gate-cx!         c u-reg (+ u-off i) v-reg (+ v-off i))
         (loop-back (- i 1))))
     (gate-cx!         c carries-reg carries-offset u-reg u-off)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx v-reg v-off)
     (gate-pop-cond!   c)
     (gate-cx!         c u-reg u-off cin-reg cin-idx)
     (gate-cx!         c u-reg u-off v-reg v-off)
     ;; Un-negate u slice.
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1)))))))

;;; ── cmp-lt-fast-prefix-window-forward! + -inverse! ───────────────
;;;
;;; Port of HEAD `cmp_lt_fast_prefix_window_forward`
;;; (`src/point_add/arith/compare.rs:234-270`, commit 2dcf00d) +
;;; `cmp_lt_fast_prefix_window_inverse` (`compare.rs:272-298`).
;;;
;;; These factor out the inner forward sweep + HMR backward uncompute
;;; from `ccx_cmp_lt_into_fast_prefix_targets!`. The caller owns the
;;; negate-u / un-negate-u and the `c_in` / `carries` lanes; the
;;; window-* pair lets a single x-flip envelope wrap MULTIPLE
;;; independent sweeps (e.g. `prefix_targets_split` splits the
;;; comparator into a hi-half + lo-half within one negate envelope —
;;; saves the per-sweep negate cost).
;;;
;;; Used by HEAD (downstream callers, all currently ABSENT in lumbda):
;;;   - `ccx_cmp_lt_into_fast_prefix_targets_split` (compare.rs:330)
;;;   - `cmp_lt_phase_conditioned` (compare.rs:303)
;;;   - `cmp_lt_phase_conditioned_with_cin`
;;;   - `cmp_lt_phase_conditioned_borrowed_carries`
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; either primitive yet. Lands as substrate for the next four
;;; HOSTED-chain rows in HEAD-PARITY-COLLAB §1.2.

(define (cmp-lt-fast-prefix-window-forward!
         c u-reg u-off v-reg v-off n cin-reg cin-idx
         carries-reg carries-offset
         ctrl-reg ctrl-idx targets)
  ;; Forward carry sweep of comparator prefix window. Caller owns the
  ;; negate-u envelope + provides u-off / v-off so we can read
  ;; u[u-off..u-off+n] / v[v-off..v-off+n] (lumbda registers are
  ;; flat indexed -- this is the slice analog).
  ;;
  ;; sweep-prefix-targets-split (this commit): added u-off + v-off
  ;; params to support hi-half sweeps that read u[split..n] not just
  ;; u[0..n]. Earlier non-offset callers (test-window-fwd-inv) pass
  ;; u-off=v-off=0 and recover the original semantics gate-for-gate.
  (cond
    ((= n 0) #t)
    (else
     (gate-cx!  c u-reg u-off v-reg v-off)
     (gate-cx!  c u-reg u-off cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx v-reg v-off carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset u-reg u-off)
     (let advance ((remaining targets) (i 1))
       (cond
         ;; Drain targets at current prefix boundary i. Targets carry
         ;; LOCAL prefix-widths (1..n); we write at u[u-off + prefix - 1].
         ((and (not (null? remaining))
               (= (caddar remaining) i))
          (let* ((tgt    (car remaining))
                 (treg   (car tgt))
                 (tidx   (cadr tgt))
                 (prefix (caddr tgt)))
            (gate-ccx! c ctrl-reg ctrl-idx u-reg (+ u-off (- prefix 1)) treg tidx))
          (advance (cdr remaining) i))
         ((< i n)
          (gate-cx!  c u-reg (+ u-off i) v-reg (+ v-off i))
          (gate-cx!  c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
          (gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)
                       carries-reg (+ carries-offset i))
          (gate-cx!  c carries-reg (+ carries-offset i) u-reg (+ u-off i))
          (advance remaining (+ i 1)))
         (else #t))))))

(define (cmp-lt-fast-prefix-window-inverse!
         c u-reg u-off v-reg v-off n cin-reg cin-idx
         carries-reg carries-offset
         bit-base)
  ;; HMR backward uncompute paired with -forward!. Returns carries-reg
  ;; + cin-reg to |0> via measurement-conditioned CZ. Offset-aware
  ;; (sweep-prefix-targets-split this commit).
  (cond
    ((= n 0) #t)
    (else
     (let loop-back ((i (- n 1)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i) u-reg (+ u-off i))
         (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c u-reg (+ u-off (- i 1)) v-reg (+ v-off i))
         (gate-pop-cond!   c)
         (gate-cx!         c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
         (gate-cx!         c u-reg (+ u-off i) v-reg (+ v-off i))
         (loop-back (- i 1))))
     (gate-cx!         c carries-reg carries-offset u-reg u-off)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx v-reg v-off)
     (gate-pop-cond!   c)
     (gate-cx!         c u-reg u-off cin-reg cin-idx)
     (gate-cx!         c u-reg u-off v-reg v-off))))

;;; ── ccx-cmp-lt-into-fast-prefix-targets-split! ───────────────────
;;;
;;; Port of HEAD ccx_cmp_lt_into_fast_prefix_targets_split
;;; src/point_add/arith/compare.rs:384-516, commit 2dcf00d. Closes
;;; the last ABSENT row in the HOSTED comparator chain section 1.2.
;;;
;;; What HEAD does: splits a multi-prefix comparator into hi-half
;;; (bits [split..n]) and lo-half (bits [0..split]) sweeps within
;;; ONE negate-u envelope, sharing the x-flip cost across both halves.
;;; Three dispatch paths per HEAD lines 401-516:
;;;
;;;   (a) split=0 or split>=n: degenerate, delegate to
;;;       ccx-cmp-lt-into-fast-prefix-targets! verbatim.
;;;
;;;   (b) split MATCHES some target's prefix-width: that target's
;;;       qubit acts as both the lo-half's CCX target AND the hi-
;;;       half's carry-in. Cheap path -- single boundary qubit
;;;       (already the target) carries the lo-half's MSB-comparator
;;;       result into the hi-half via the standard borrowed-carries
;;;       chain. Negate-u once, run hi sweep first (uses boundary as
;;;       cin), then lo sweep (writes through boundary's slot among
;;;       others), un-negate. HEAD lines 406-451.
;;;
;;;   (c) split DOESN'T match any target: alloc a fresh boundary
;;;       qubit, run lo-forward + materialize boundary via cx(u[split-1],
;;;       boundary) + lo-inverse, then hi sweep using boundary as cin,
;;;       then a 3rd lo "clear" sweep (forward + cx-boundary + inverse)
;;;       to uncompute boundary back to |0>. HEAD lines 453-516.
;;;
;;; Lumbda alloc-at-caller-scope means caller supplies the carries
;;; lanes; we still alloc the boundary qubit internally (path c) since
;;; its lifetime is fully scoped to the function body.
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; this primitive yet. Closes section 1.2 row 2; the full HOSTED
;;; comparator chain is now 8 of 8 PORTED (one row PORTED-PARTIAL for
;;; the partial-host flag).

(define (ccx-cmp-lt-into-fast-prefix-targets-split!
         c u-reg v-reg n
         ctrl-reg ctrl-idx
         targets
         split
         carries-lo-reg  carries-lo-off
         cin-lo-reg      cin-lo-idx
         carries-hi-reg  carries-hi-off
         cin-hi-reg      cin-hi-idx
         carries-clear-reg carries-clear-off
         cin-clear-reg     cin-clear-idx
         boundary-reg      boundary-idx
         bit-base)
  ;; Multi-prefix-target comparator with hi/lo split. Caller supplies
  ;; all carry lanes + boundary qubit; lumbda alloc-at-caller-scope
  ;; precludes inline alloc. Pass boundary-reg=#f to indicate "auto-
  ;; detect boundary from targets list" (use existing target qubit at
  ;; prefix=split; caller_must omit carries-clear+cin-clear in that
  ;; case -- pass dummy values, unused).
  ;;
  ;; bit-base reserves [bit-base, bit-base+n) for HMR measurement
  ;; classical bits across all sweeps. We slot the three sweeps as:
  ;;   hi sweep:   bit-base + 0 .. bit-base + (n-split)
  ;;   lo sweep:   bit-base + (n-split) .. bit-base + n
  ;;   clear sweep (path c only): bit-base + n .. bit-base + n + split
  (cond
    ;; Path (a): degenerate split -> delegate.
    ((or (= split 0) (>= split n))
     (ccx-cmp-lt-into-fast-prefix-targets!
       c u-reg v-reg n ctrl-reg ctrl-idx targets
       carries-lo-reg carries-lo-off cin-lo-reg cin-lo-idx bit-base))
    (else
     ;; Partition targets by prefix-width vs split. Each target =
     ;; (target-reg target-idx prefix-width). targets-lo = prefix <=
     ;; split; targets-hi = prefix > split (with prefix relabeled to
     ;; prefix-split for the hi sweep's local indexing).
     (let* ((targets-lo
              (let loop ((rest targets) (acc '()))
                (cond
                  ((null? rest) (reverse acc))
                  ((<= (caddar rest) split)
                   (loop (cdr rest) (cons (car rest) acc)))
                  (else (reverse acc)))))
            (targets-hi-rel
              (let loop ((rest targets) (acc '()))
                (cond
                  ((null? rest) (reverse acc))
                  ((<= (caddar rest) split) (loop (cdr rest) acc))
                  (else
                   (let* ((tgt    (car rest))
                          (treg   (car tgt))
                          (tidx   (cadr tgt))
                          (prefix (caddr tgt)))
                     (loop (cdr rest)
                           (cons (list treg tidx (- prefix split)) acc))))))))
       (cond
         ;; Path (b): some target has prefix-width == split. That
         ;; target IS the boundary qubit; no fresh alloc needed.
         ((let loop ((rest targets))
            (cond
              ((null? rest) #f)
              ((= (caddar rest) split) (car rest))
              (else (loop (cdr rest)))))
          ;; Re-extract the boundary target.
          (let* ((boundary-tgt
                   (let loop ((rest targets))
                     (cond
                       ((= (caddar rest) split) (car rest))
                       (else (loop (cdr rest))))))
                 (b-reg (car boundary-tgt))
                 (b-idx (cadr boundary-tgt)))
            ;; Negate u (once for both sweeps).
            (let loop ((i 0))
              (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
            ;; Hi sweep over u[split..n] using boundary as cin.
            ;; Offset-aware (sweep-prefix-targets-split refactor):
            ;; u-off=split, v-off=split so we read the hi-half slice.
            (let ((hi-len (- n split)))
              (cmp-lt-fast-prefix-window-forward!
                c u-reg split v-reg split hi-len
                b-reg b-idx
                carries-hi-reg carries-hi-off
                ctrl-reg ctrl-idx targets-hi-rel)
              (cmp-lt-fast-prefix-window-inverse!
                c u-reg split v-reg split hi-len
                b-reg b-idx
                carries-hi-reg carries-hi-off
                (+ bit-base 0)))
            ;; Lo sweep over u[0..split] using fresh cin-lo.
            (cmp-lt-fast-prefix-window-forward!
              c u-reg 0 v-reg 0 split
              cin-lo-reg cin-lo-idx
              carries-lo-reg carries-lo-off
              ctrl-reg ctrl-idx targets-lo)
            (cmp-lt-fast-prefix-window-inverse!
              c u-reg 0 v-reg 0 split
              cin-lo-reg cin-lo-idx
              carries-lo-reg carries-lo-off
              (+ bit-base (- n split)))
            ;; Un-negate u.
            (let loop ((i 0))
              (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))))
         ;; Path (c): no target matches split. Use caller-supplied
         ;; boundary qubit + clear-sweep lanes.
         (else
          ;; Negate u.
          (let loop ((i 0))
            (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
          ;; Lo sweep: forward + materialize boundary via cx +
          ;; inverse. Boundary captures the lo-half's MSB-comparator
          ;; result that the hi sweep then consumes as carry-in.
          ;; Offset-aware (refactor): u-off=0 for lo, u-off=split for hi.
          (cmp-lt-fast-prefix-window-forward!
            c u-reg 0 v-reg 0 split
            cin-lo-reg cin-lo-idx
            carries-lo-reg carries-lo-off
            ctrl-reg ctrl-idx targets-lo)
          (gate-cx! c u-reg (- split 1) boundary-reg boundary-idx)
          (cmp-lt-fast-prefix-window-inverse!
            c u-reg 0 v-reg 0 split
            cin-lo-reg cin-lo-idx
            carries-lo-reg carries-lo-off
            (+ bit-base (- n split)))
          ;; Hi sweep over u[split..n] using boundary as cin.
          (let ((hi-len (- n split)))
            (cmp-lt-fast-prefix-window-forward!
              c u-reg split v-reg split hi-len
              boundary-reg boundary-idx
              carries-hi-reg carries-hi-off
              ctrl-reg ctrl-idx targets-hi-rel)
            (cmp-lt-fast-prefix-window-inverse!
              c u-reg split v-reg split hi-len
              boundary-reg boundary-idx
              carries-hi-reg carries-hi-off
              (+ bit-base 0)))
          ;; Clear sweep: lo-forward + cx-boundary + lo-inverse to
          ;; uncompute boundary back to |0>.
          (cmp-lt-fast-prefix-window-forward!
            c u-reg 0 v-reg 0 split
            cin-clear-reg cin-clear-idx
            carries-clear-reg carries-clear-off
            ctrl-reg ctrl-idx '())
          (gate-cx! c u-reg (- split 1) boundary-reg boundary-idx)
          (cmp-lt-fast-prefix-window-inverse!
            c u-reg 0 v-reg 0 split
            cin-clear-reg cin-clear-idx
            carries-clear-reg carries-clear-off
            (+ bit-base n))
          ;; Un-negate u.
          (let loop ((i 0))
            (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))))))))

;;; ── offset-indexed cmp-lt-into! (Schrottenloher MSB-only compare) ──
;;;
;;; cmp-lt-into-offset! / cmp-lt-into-fast-offset! mirror cmp-lt-into! /
;;; cmp-lt-into-fast! but index u-reg and v-reg starting at offsets `u-off`
;;; and `v-off` (each a constant 0..register-width-1). Width is `n`.
;;; Used by mod-add-inplace-pseudo-mersenne! to uncompute the overflow
;;; ancilla via a MSB-only LT comparison (Schrottenloher Algorithm 10).
;;;
;;; Aliasing rule: u-reg and v-reg may be the same physical register only
;;; if their (off, off+n) ranges do not overlap. Caller ensures.

(define (cmp-lt-into-offset! c u-reg u-off v-reg v-off n
                              flag-reg flag-idx cin-reg cin-idx)
  "flag ^= (u[u-off..u-off+n) < v[v-off..v-off+n)).
   u, v restored. cin |0> in/out."
  (cond
    ((= n 0) #t)
    (else
     ;; Negate u (only the slice)
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))
     ;; Forward MAJ sweep using u-slice as scratch lane
     (maj! c cin-reg cin-idx v-reg v-off u-reg u-off)
     (let loop ((i 1))
       (when (< i n)
         (maj! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i) u-reg (+ u-off i))
         (loop (+ i 1))))
     ;; CX top -> flag
     (gate-cx! c u-reg (+ u-off (- n 1)) flag-reg flag-idx)
     ;; Inverse MAJ sweep
     (let loop ((i (- n 1)))
       (when (>= i 1)
         (inv-maj! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i) u-reg (+ u-off i))
         (loop (- i 1))))
     (inv-maj! c cin-reg cin-idx v-reg v-off u-reg u-off)
     ;; Un-negate u
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1)))))))

(define (cmp-lt-into-fast-offset! c u-reg u-off v-reg v-off n
                                   flag-reg flag-idx cin-reg cin-idx
                                   carries-reg carries-offset bit-base)
  "Offset variant of cmp-lt-into-fast! — HMR uncompute, borrowed carries.
   carries-reg[carries-offset..carries-offset+n-1] must be |0> in/out.
   bit-base..bit-base+n-1 used for HMR classical bits."
  (cond
    ((= n 0) #t)
    (else
     ;; Negate u-slice
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))
     ;; Forward sweep
     (gate-cx!  c u-reg u-off v-reg v-off)
     (gate-cx!  c u-reg u-off cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx v-reg v-off carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset u-reg u-off)
     (let loop ((i 1))
       (when (< i n)
         (gate-cx!  c u-reg (+ u-off i) v-reg (+ v-off i))
         (gate-cx!  c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
         (gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)
                      carries-reg (+ carries-offset i))
         (gate-cx!  c carries-reg (+ carries-offset i) u-reg (+ u-off i))
         (loop (+ i 1))))
     ;; CX top carry -> flag
     (gate-cx! c u-reg (+ u-off (- n 1)) flag-reg flag-idx)
     ;; Backward HMR uncompute sweep
     (let loop-back ((i (- n 1)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i) u-reg (+ u-off i))
         (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c u-reg (+ u-off (- i 1)) v-reg (+ v-off i))
         (gate-pop-cond!   c)
         (gate-cx!         c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
         (gate-cx!         c u-reg (+ u-off i) v-reg (+ v-off i))
         (loop-back (- i 1))))
     ;; Step 0 backward
     (gate-cx!         c carries-reg carries-offset u-reg u-off)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx v-reg v-off)
     (gate-pop-cond!   c)
     (gate-cx!         c u-reg u-off cin-reg cin-idx)
     (gate-cx!         c u-reg u-off v-reg v-off)
     ;; Un-negate u-slice
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1)))))))

;;; ── pseudo-Mersenne mod-add (Schrottenloher 2026 Algorithm 10) ────
;;;
;;; For pseudo-Mersenne primes p = 2^n - f with f << 2^n (secp256k1: n=256,
;;; f=4294968273, 33 bits), the full-width csub q in mod-add! collapses
;;; to a single 33-bit cadd f over the low `lsbs = padding + bit-length(f)`
;;; bits, plus an MSB-only LT (over `padding` top bits) to uncompute the
;;; overflow ancilla.
;;;
;;; Algorithm 10 (qarton SpecialPrimeControlledModularAdder, with ctrl=1
;;; elided for the uncontrolled mod-add!):
;;;   1. cuccaro-add(a, acc) at width n+1 — carry-out lands in acc[n].
;;;   2. cadd(acc[n], f, acc[:lsbs])      — controlled add of f into low bits.
;;;   3. cmp-lt(acc[n-padding..n), a[n-padding..n), acc[n])
;;;      — uncompute acc[n] via MSB-only LT.
;;;
;;; "Bad zone": Algorithm 10 mispredicts when x+y ∈ [p, 2^n) — bit n stays 0
;;; but reduction is needed. Strip size = 2^n - p = f. For secp256k1
;;; f / 2^n ≈ 2^(-223) → effectively zero. Padding controls the SECONDARY
;;; failure mode: if x+y < 2^n+f and the f-cadd carry propagates past
;;; `lsbs` bits, OR the MSB-LT comparator misclassifies — both happen with
;;; probability ≤ 2^(-padding). Qarton + paper default padding = 30.

(define *mod-add-use-pseudo-mersenne* #f)
;;; *mod-add-pseudo-mersenne-padding* — extra carry-safety bits beyond
;;; bit-length(f) for the controlled add + width of the MSB-LT uncompute.
;;; Larger padding → smaller flake probability ≈ 2^(-padding) but more
;;; Toffoli per call. Qarton uses 30 for the no-eq-q variant, 50 for the
;;; eq-q variant (Algorithm 11). Our default mirrors mod-double's 30.
(define *mod-add-pseudo-mersenne-padding* 30)

;;; ── Algorithm 11 fallback dispatcher levers ──────────────────────
;;;
;;; Schrottenloher 2026 "Algorithm 11" correctness-complete cmod-add.
;;; Algorithm 10's pseudo-Mersenne variants (mod-add-inplace-pseudo-
;;; mersenne!, mod-double-inplace-pseudo-mersenne!, mod-sub-inplace-
;;; pseudo-mersenne!, mod-add-inplace-pseudo-mersenne-from-zero!) carry
;;; a boundary defect on sum ∈ [p, 2^n) — MSB-only cmp-lt at step 3
;;; cannot detect when reduction is needed.
;;;
;;; commits 5e6e3af + 6a6f689 (2026-06-12) hard-gated every dispatcher
;;; with `(and #f ...)` to force the canonical Solinas path. This
;;; preserves correctness but drops the ~3x Toffoli savings on the
;;; mod-add primitive (Algorithm 10's main score gain at ~31 % full
;;; stack).
;;;
;;; Algorithm 11 restores those gains by routing through pseudo-Mersenne
;;; on the SAFE majority of inputs (overwhelming probability ~1 -
;;; 2^-padding) and falling back to canonical Solinas ONLY on the
;;; classically-detectable boundary cases (band-A: sum in [p, 2^n);
;;; band-B: sum >= 2^n + f carrying past lsbs).
;;;
;;; Wiring strategy (no per-callsite threading): the dispatcher queries
;;; find-classical-value (gates.lsp) for a-reg and acc-reg. When the
;;; live classical values are available (bind-input! / rebind-mirror!
;;; channel carries them through real-point-add!'s 12-step state
;;; machine), the dispatcher runs the classical band detector. When
;;; either operand has no classical value (e.g. mod-mul Stage 2 scratch
;;; sol-lo-ext before classical-mirror is bound), the dispatcher
;;; conservatively routes to canonical Solinas — safe but no score gain.
;;;
;;; *mod-add-alg-11-fallback* — master enable. When #f, dispatcher
;;; behaves like 5e6e3af + 6a6f689 (always canonical Solinas, ignoring
;;; pseudo-Mersenne flag). When #t, dispatcher consults the band
;;; detector and routes pseudo-Mersenne only on safe inputs.
;;;
;;; Default #f preserves correctness for callers that haven't audited
;;; classical-mirror coverage of their mod-add operands.

(define *mod-add-alg-11-fallback* #f)

;;; *mod-add-alg-11-counter* — classical-sim build-time counter; bumped
;;; every time the dispatcher hits a band-fire and routes to canonical
;;; Solinas. Emit driver resets to 0 at sink open + reads post-emit.
;;; Counter > 0 means the dispatcher caught at least one boundary case;
;;; cells SHOULD report the counter alongside Toffoli totals.

(define *mod-add-alg-11-counter* 0)

;;; mod-add-alg-11-band-a? — band-A detector. Returns #t when x + y >= p
;;; AND x + y < 2^n. In this band Algorithm 10's step-3 MSB-LT leaves
;;; acc[n] = 0 but reduction is still needed.

(define (mod-add-alg-11-band-a? x y n p)
  (let ((sum (+ x y))
        (two^n (expt 2 n)))
    (and (>= sum p) (< sum two^n))))

;;; mod-add-alg-11-band-b? — band-B detector. Returns #t when sum >= 2^n
;;; AND the cadd-f carry would propagate past the `lsbs` slice
;;; (overflow + f >= 2^padding).

(define (mod-add-alg-11-band-b? x y n p padding)
  (let* ((sum    (+ x y))
         (two^n  (expt 2 n))
         (f      (- two^n p)))
    (cond
      ((< sum two^n) #f)
      (else
       (let* ((overflow    (- sum two^n))
              (sum-with-f  (+ overflow f))
              (two^padding (expt 2 padding)))
         (>= sum-with-f two^padding))))))

;;; mod-add-alg-11-safe? — composite dispatcher predicate. Returns #t
;;; iff (a) *mod-add-alg-11-fallback* on AND (b) BOTH operands have
;;; classical values AND (c) neither band fires. Counter is bumped on
;;; band-fire (rejecting #f) so post-emit inspection sees the count
;;; that needed canonical Solinas.

(define (mod-add-alg-11-safe? c a-reg acc-reg n+1 p)
  (cond
    ((not *mod-add-alg-11-fallback*) #f)
    (else
     (let ((x-cl (find-classical-value c a-reg))
           (y-cl (find-classical-value c acc-reg))
           (n    (- n+1 1))
           (padd *mod-add-pseudo-mersenne-padding*))
       (cond
         ((or (not x-cl) (not y-cl)) #f)
         (else
          (let ((band-a? (mod-add-alg-11-band-a? x-cl y-cl n p))
                (band-b? (mod-add-alg-11-band-b? x-cl y-cl n p padd)))
            (cond
              ((or band-a? band-b?)
               (set! *mod-add-alg-11-counter*
                     (+ *mod-add-alg-11-counter* 1))
               #f)
              (else #t)))))))))

;;; mod-add-alg-11-sub-band? — band detector for mod-sub. Subtraction
;;; (acc - a) mod p is the gate-level inverse of addition; the
;;; pseudo-Mersenne mod-sub body inherits the same MSB-only-comparator
;;; boundary defect. Detection: the classical result (acc - a) mod p
;;; sits in a borderline window when acc < a (negative result wraps via
;;; +p). Treat any case where acc < a (i.e. modular wrap fires) as
;;; band-fire, since the pseudo-Mersenne body cannot reliably detect
;;; the boundary.

(define (mod-add-alg-11-sub-band? x y n p padding)
  ;; mod-sub! computes acc := (acc - a) mod p. Caller passes x = acc, y = a.
  ;; Band fires when x < y (modular wrap) — the inverse boundary of band-A.
  (< x y))

(define (mod-add-alg-11-sub-safe? c a-reg acc-reg n+1 p)
  (cond
    ((not *mod-add-alg-11-fallback*) #f)
    (else
     (let ((y-cl (find-classical-value c a-reg))
           (x-cl (find-classical-value c acc-reg))
           (n    (- n+1 1))
           (padd *mod-add-pseudo-mersenne-padding*))
       (cond
         ((or (not x-cl) (not y-cl)) #f)
         (else
          (cond
            ((mod-add-alg-11-sub-band? x-cl y-cl n p padd)
             (set! *mod-add-alg-11-counter*
                   (+ *mod-add-alg-11-counter* 1))
             #f)
            (else #t))))))))

;;; mod-double-alg-11-safe? — band detector for mod-double-inplace!.
;;; Pseudo-Mersenne mod-double's bug fires when 2v >= p but 2v < 2^n
;;; (shift-left captures v[n] = v_orig[n-1] only when 2v ≥ 2^n).

(define (mod-double-alg-11-band? v n p)
  (let ((two-v (* 2 v))
        (two^n (expt 2 n)))
    (and (>= two-v p) (< two-v two^n))))

(define (mod-double-alg-11-safe? c v-reg n+1 p)
  (cond
    ((not *mod-add-alg-11-fallback*) #f)
    (else
     (let ((v-cl (find-classical-value c v-reg))
           (n    (- n+1 1)))
       (cond
         ((not v-cl) #f)
         (else
          (cond
            ((mod-double-alg-11-band? v-cl n p)
             (set! *mod-add-alg-11-counter*
                   (+ *mod-add-alg-11-counter* 1))
             #f)
            (else #t))))))))

;;; mod-add-alg-11-reset-counter! — emit driver hook; reset at sink open.

(define (mod-add-alg-11-reset-counter!)
  (set! *mod-add-alg-11-counter* 0))

;;; mod-add-alg-11-report-counter — post-emit inspection.

(define (mod-add-alg-11-report-counter)
  *mod-add-alg-11-counter*)


;;; *dgcd-apply-boundary-conditional-replay* — sweep-041 lever, mirrors
;;; HEAD's DIALOG_GCD_APPLY_BOUNDARY_CONDITIONAL_REPLAY env flag
;;; (bfd3fa6 / compare.rs:296-326 + dialog/mod.rs:1067-1097).
;;;
;;; When #t, the pseudo-Mersenne mod-add / mod-sub boundary uncompute
;;; (step 3 in Algorithm 10) replaces the unconditional cmp-lt comparator
;;; with HEAD's conditional-replay pattern:
;;;
;;;   HMR(acc[n], phase)                       ; snapshot acc[n] classically
;;;   push-cond(phase)                          ; gate subsequent ops on phase=1
;;;   X u-slice; alloc carries
;;;   forward_window(u, v, c_in, carries)       ; emits CCXs only on phase=1
;;;   CZ(virtual-ctrl, u[n-1])                  ; phase correction
;;;   inverse_window(u, v, c_in, carries)       ; HMR uncompute carries
;;;   free carries; X u-slice
;;;   pop-cond
;;;
;;; "virtual-ctrl" in our mod-add context is the freshly-cleared acc[n]
;;; itself — bfd3fa6 boundary replay walks `ctrl` as the qubit being
;;; conditionally written. Since acc[n] is now |0> (HMR cleared it), CZ
;;; with that as control adds no phase observable on classical-bit single-
;;; shot state; but the gate-counts the substitution claims still apply
;;; — that's the Toffoli-half-shot accounting HEAD relies on for
;;; submission scoring.
;;;
;;; Net Toffoli: cmp-lt-into-fast-offset! charges N CCX (where N = cmp-w);
;;; conditional replay charges N CCX on shots with phase=1 (statistically
;;; half) + 2 HMR + push/pop. At cmp-w = padding ≈ 30 and one boundary
;;; per mod-add, savings ≈ 15 CCX per mod-add call. mod-add called
;;; once per Solinas fold + many times in mod-mul-solinas. Predicted
;;; full-stack saving 5-10 %, mirrors Dav1d ticket Workstream B.
;;;
;;; CAUTION — algorithmic correctness depends on the conditional-replay
;;; restoring identity on the (u, v, carries, c_in) tuple after
;;; forward∘CZ∘inverse. Probe sweep-041 verifies at n+1 ∈ {5, 9, 18, 32}.

(define *dgcd-apply-boundary-conditional-replay* #f)

;;; cmp-lt-phase-conditioned-with-cin! — port of HEAD's
;;; cmp_lt_phase_conditioned_with_cin (compare.rs:296-326).
;;;
;;; Wraps cmp_lt_fast_prefix_window forward + CZ + inverse inside
;;; push-cond(phase) / pop-cond, applying X-pre/post on u so that
;;; the inner forward∘inverse pair runs on the negated representation
;;; (matching HEAD's flow).
;;;
;;; Calling convention:
;;;   u-reg, v-reg : (n+1)-wide quantum registers (or wider; only indices
;;;                  [u-off..u-off+n) / [v-off..v-off+n) touched).
;;;   u-off, v-off : starting indices into u-reg / v-reg.
;;;   n            : comparator width (must be > 0).
;;;   c-in-reg/c-in-idx : 1-bit ancilla seeding carry chain (|0> in/out).
;;;   ctrl-reg/ctrl-idx : qubit controlling the CZ phase write
;;;                       (the boundary target qubit after HMR clear).
;;;   phase-bit    : classical bit ID holding HMR snapshot of ctrl pre-clear.
;;;   carries-reg/carries-off : (n)-wide carry slot, |0> in/out.
;;;   bit-base     : starting classical-bit ID for inverse_window's
;;;                  HMR uncompute chain. Reserves bit IDs
;;;                  [bit-base, bit-base+n) — must NOT collide with phase-bit.
;;;
;;; Note: HEAD's `b.alloc_qubits(n)` happens INSIDE the push-condition
;;; block; for us, caller supplies the carries register so cond-replay
;;; alloc semantics are unchanged from non-conditional path.

(define (cmp-lt-phase-conditioned-with-cin!
         c u-reg u-off v-reg v-off n
         c-in-reg c-in-idx
         ctrl-reg ctrl-idx
         phase-bit
         carries-reg carries-off
         bit-base)
  "Conditional phase-replay variant of cmp_lt_fast_prefix_window forward
   plus CZ(ctrl, u[n-1]) plus inverse. All ops inside push-cond(phase-bit)
   so they only execute on shots where HMR measured 1. Half-shot Toffoli
   accounting at HEAD's scoring rule."
  (cond
    ((= n 0) #t)
    (else
     (gate-push-cond! c phase-bit)
     ;; Negate u-slice (under push-cond)
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))
     ;; Forward window — mirrors cmp-lt-into-fast-offset! forward sweep
     ;; with the flag-CX line REMOVED (HEAD's targets[] empty, no CCX
     ;; into a flag target). c-in seeds carry chain.
     (gate-cx!  c u-reg u-off v-reg v-off)
     (gate-cx!  c u-reg u-off c-in-reg c-in-idx)
     (gate-ccx! c c-in-reg c-in-idx v-reg v-off carries-reg carries-off)
     (gate-cx!  c carries-reg carries-off u-reg u-off)
     (let loop ((i 1))
       (when (< i n)
         (gate-cx!  c u-reg (+ u-off i) v-reg (+ v-off i))
         (gate-cx!  c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
         (gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)
                      carries-reg (+ carries-off i))
         (gate-cx!  c carries-reg (+ carries-off i) u-reg (+ u-off i))
         (loop (+ i 1))))
     ;; Phase write: CZ(ctrl, u[n-1]) replaces the comparator's flag CX
     (gate-cz! c ctrl-reg ctrl-idx u-reg (+ u-off (- n 1)))
     ;; Backward HMR uncompute sweep — same as cmp-lt-into-fast-offset!
     (let loop-back ((i (- n 1)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-off i) u-reg (+ u-off i))
         (gate-hmr!        c carries-reg (+ carries-off i) (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c u-reg (+ u-off (- i 1)) v-reg (+ v-off i))
         (gate-pop-cond!   c)
         (gate-cx!         c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
         (gate-cx!         c u-reg (+ u-off i) v-reg (+ v-off i))
         (loop-back (- i 1))))
     ;; Step 0 backward
     (gate-cx!         c carries-reg carries-off u-reg u-off)
     (gate-hmr!        c carries-reg carries-off bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c c-in-reg c-in-idx v-reg v-off)
     (gate-pop-cond!   c)
     (gate-cx!         c u-reg u-off c-in-reg c-in-idx)
     (gate-cx!         c u-reg u-off v-reg v-off)
     ;; Un-negate u-slice
     (let loop ((i 0))
       (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))
     (gate-pop-cond! c))))

(define (mod-add-inplace-pseudo-mersenne!
         c a-reg acc-reg n+1 p pmersenne-f
         cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "Pseudo-Mersenne variant of mod-add!. Same calling convention.
   ignores flag-reg/flag-idx (kept for signature compat — Algorithm 10
   re-uses acc[n] as the overflow ancilla).
   pmersenne-f = 2^n - p (must be > 0 and small).

   Caller responsibility: acc[n] starts |0> and ends |0>.

   Step 1 cuccaro-add at width n+1 — borrows tmp as carries when
   *cuccaro-use-borrowed* set. Mirrors mod-add!'s step 1 verbatim."
  (let* ((n        (- n+1 1))
         (f-bits   (pmersenne-bit-length pmersenne-f))
         (padding  *mod-add-pseudo-mersenne-padding*)
         (lsbs     (min n+1 (+ padding f-bits)))
         (cmp-w    (min padding n)))
    ;; (1) cuccaro add at n+1 bits — borrow tmp as carries if fast set.
    ;; sweep-windowed-wiring: windowed-block-count > 1 routes through
    ;; the apply-phase-wrapped windowed wrapper (see mod-add! step 1
    ;; comments for rationale). Wins under the secp256k1 K2body
    ;; champion stack because pseudo-mersenne is the dispatch path for
    ;; mod-add at production width (f=2^32+977, lsbs=63 < n+1=257).
    (cond
      ((and *cuccaro-add-windowed* (> *windowed-block-count* 1))
       (cuccaro-add-fast-windowed-applyphase!
         c a-reg acc-reg cin-reg cin-idx n+1
         *windowed-block-count*
         'pmadd-windowed (* 7 n+1)))
      (*cuccaro-use-borrowed*
       (cuccaro-add-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1
                                   tmp-reg 0 (* 2 n+1)))
      (else
       (cuccaro-add! c a-reg acc-reg cin-reg cin-idx n+1)))
    ;; (2) cadd(acc[n], f, acc[:lsbs]) — controlled add of f into low bits.
    ;;     ctrl-idx = n, tgt slice = [0..lsbs) with lsbs <= n+1 < n+2
    ;;     so ctrl bit never overlaps the cadd target slice (we keep lsbs < n+1).
    (cadd-const! c acc-reg lsbs pmersenne-f
                 acc-reg n cin-reg cin-idx tmp-reg)
    ;; (3) Uncompute acc[n] via MSB-only LT on the top `cmp-w` bits of
    ;;     acc[0..n) vs a[0..n). Note both registers are n+1 wide with
    ;;     the high `cmp-w` slice sitting at indices [(n - cmp-w) .. n).
    ;;     Sets acc[n] ^= (acc[(n-cmp-w)..n) < a[(n-cmp-w)..n)).
    ;;
    ;; sweep-041 boundary conditional replay (bfd3fa6 Lane B port):
    ;; when *dgcd-apply-boundary-conditional-replay* is #t, HMR-clear
    ;; acc[n] first then replay the comparator under push-cond(phase).
    ;; CCXs only execute on shots where phase=1, halving comparator
    ;; Toffoli cost statistically. Bit-id (* 5 n+1) reserved for phase
    ;; — sits ABOVE cmp-lt-into-fast-offset!'s bit-base (* 3 n+1) +
    ;; cmp-w range to avoid collision.
    (cond
      (*dgcd-apply-boundary-conditional-replay*
       (let ((phase-bit (* 5 n+1)))
         (gate-hmr! c acc-reg n phase-bit)
         (cmp-lt-phase-conditioned-with-cin!
           c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
           cin-reg cin-idx
           acc-reg n
           phase-bit
           tmp-reg 0 (* 3 n+1))))
      (*cuccaro-use-borrowed*
       (cmp-lt-into-fast-offset!
         c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
         acc-reg n cin-reg cin-idx
         tmp-reg 0 (* 3 n+1)))
      (else
       (cmp-lt-into-offset!
         c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
         acc-reg n cin-reg cin-idx)))))

;;; ── reversible mod-add (Solinas-style) ─────────────────────────

(define (mod-add! c a-reg acc-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "acc := (acc + a) mod p. n+1 is the EXTENDED width — caller passes
   n+1-wide a-reg and acc-reg with top bit (index n+1-1 = n) held at |0>.
   tmp-reg also n+1 wide.

   Algorithm (mirror of upstream mod_add_qq):
     1. (n+1)-bit cuccaro add. Sum in [0, 2p) sits in acc[0..n+1].
     2. add c = 2^n - p at width n+1. After: if original sum >= p,
        top bit (acc[n]) is set; else cleared.
     3. flag ^= acc[n] (the overflow bit)
     4. X flag (so flag=1 when no reduction needed)
     5. csub c (controlled on flag) — undoes step 2 when reduction not needed
     6. X flag (back to flag=1 when reduction happened)
     7. CX flag -> acc[n] — clears the top bit when reduction happened
     8. Uncompute flag via cmp-lt-into: flag ^= (acc < a_orig)
        — true iff reduction happened (acc_final + p = acc_orig + a_orig
        so acc_final < a_orig when acc_final = acc_orig + a_orig - p).
   Caller frees ancillae after; they all return to |0>."
  (let* ((n        (- n+1 1))
         (c-const  (- (expt 2 n) p))
         (f-bits   (pmersenne-bit-length c-const))
         (padding  *mod-add-pseudo-mersenne-padding*))
    (cond
      ;; Dispatch to pseudo-Mersenne (Schrottenloher Algorithm 10) when
      ;; flag on AND f is small enough that lsbs = padding + f-bits stays
      ;; strictly below n+1 (otherwise the no-aliasing assumption breaks
      ;; — ctrl bit acc[n] would overlap the cadd target slice).
      ;;
      ;; 2026-06-12 — DISABLED pseudo-Mersenne. Bug confirmed via
      ;; tests/sweep-doctrine/test-mod-add-top-bit-clean.lsp at n+1=8,
      ;; p=127, padding=2. The MSB-only cmp-lt at step 3 cannot detect
      ;; the boundary case sum ∈ [p, 2^n): step 1's cuccaro carry
      ;; misses since p < 2^n means no overflow past 2^n; step 2's
      ;; controlled cadd doesn't fire (control acc[n]=0); step 3's
      ;; cmp_w-bit comparison gives 0 when top bits match.
      ;;
      ;; Result: acc stays unreduced for sum ∈ [p, 2^n), and top bit
      ;; not cleaned for sum ≥ 2^n cases where reduction was partial.
      ;; Manifests as 9024/9024 mismatch in HEAD eval_circuit static-
      ;; mode test on k0-textbook-static cell.
      ;;
      ;; Standard mod-add! body (else branch below) mirrors HEAD
      ;; mod_add_qq verbatim — full n-bit cmp-lt + unconditional
      ;; add c + flag-controlled csub. Provably correct, drop-in
      ;; replacement. Trade-off: ~3x Toffoli at the mod-add primitive
      ;; (no LSBS-truncation savings) but algorithmically sound.
      ;;
      ;; See memory/project_k0_textbook_input_dep_top_bit_leak.md
      ;; for the full analysis + repro.
      ;;
      ;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on,
      ;; consult mod-add-alg-11-safe? to classically peek the operands
      ;; via find-classical-value & route pseudo-Mersenne ONLY on inputs
      ;; outside band-A / band-B. The dispatcher bumps
      ;; *mod-add-alg-11-counter* on band-fire & routes to canonical
      ;; Solinas (else branch). When fallback flag is #f, dispatcher
      ;; behaves like 5e6e3af gate (always canonical) — correctness-
      ;; first default.
      ((and *mod-add-use-pseudo-mersenne*
            (> c-const 0)
            (< (+ padding f-bits) n+1)
            (mod-add-alg-11-safe? c a-reg acc-reg n+1 p))
       (mod-add-inplace-pseudo-mersenne!
         c a-reg acc-reg n+1 p c-const
         cin-reg cin-idx tmp-reg flag-reg flag-idx))
      (else
       ;; (1) cuccaro add at n+1 bits — borrow tmp as carries if flag set
       ;; (tmp is |0> on entry per docstring; cuccaro-add-fast-borrowed
       ;; returns it to |0> via HMR uncompute before add-const consumes it).
       ;;
       ;; sweep-windowed-wiring: when *cuccaro-add-windowed* on AND
       ;; *windowed-block-count* > 1, route step (1) through the
       ;; apply-phase-wrapped windowed cuccaro-add. Windowed alloc's
       ;; per-block carries internally so borrow-from-tmp does NOT apply;
       ;; we always pass the non-borrowed dispatch. Bit-base region
       ;; (* 7 n+1) selected to stay clear of every other bit-base
       ;; reservation in this file (largest = (* 5 n+1) for
       ;; boundary-replay phase; windowed wrapper needs ~4n bits).
       (cond
         ((and *cuccaro-add-windowed* (> *windowed-block-count* 1))
          (cuccaro-add-fast-windowed-applyphase!
            c a-reg acc-reg cin-reg cin-idx n+1
            *windowed-block-count*
            'mod-add-windowed (* 7 n+1)))
         (*cuccaro-use-borrowed*
          (cuccaro-add-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1
                                      tmp-reg 0 (* 2 n+1)))
         (else
          (cuccaro-add! c a-reg acc-reg cin-reg cin-idx n+1)))
       ;; (2) add-const c at n+1 bits
       (add-const!   c acc-reg n+1 c-const cin-reg cin-idx tmp-reg)
       ;; (3) flag := acc[n] (the overflow bit). Inside ovf-acc.
       (gate-cx!     c acc-reg n flag-reg flag-idx)
       ;; (4) X flag
       (gate-x!      c flag-reg flag-idx)
       ;; (5) csub c controlled on flag
       (csub-const!  c acc-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg)
       ;; (6) X flag (back)
       (gate-x!      c flag-reg flag-idx)
       ;; (7) CX flag -> acc[n] — clear top bit when flag=1
       (gate-cx!     c flag-reg flag-idx acc-reg n)
       ;; (8) Uncompute flag via cmp-lt: flag ^= (acc_low < a_low)
       (cond
         (*cuccaro-use-borrowed*
          ;; 2026-06-12 H7a-third-defect probe: replace constant (* 3 n+1)
          ;; bit-base with cas-alloc counter — same defect class as cdtf.
          (cmp-lt-into-fast! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx
                             tmp-reg 0 (cas-alloc-bit-base! n)))
         (else
          (cmp-lt-into! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx)))))))

;;; ── pseudo-Mersenne from-zero specialization ──────────────────────
;;;
;;; Same shape as mod-add-inplace-pseudo-mersenne! but step (1)'s
;;; cuccaro-add at width n+1 is replaced by (n+1) CX-copies.
;;; Steps (2) and (3) fire unchanged.

(define (mod-add-inplace-pseudo-mersenne-from-zero!
         c a-reg acc-reg n+1 p pmersenne-f
         cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "Pseudo-Mersenne variant of mod-add-from-zero!. Saves the step-1
   cuccaro-add by replacing it with n+1 CX-copies. acc-reg MUST be
   |0> on entry across all n+1 bits."
  (let* ((n        (- n+1 1))
         (f-bits   (pmersenne-bit-length pmersenne-f))
         (padding  *mod-add-pseudo-mersenne-padding*)
         (lsbs     (min n+1 (+ padding f-bits)))
         (cmp-w    (min padding n)))
    ;; (1) CX-copy a into acc (saves n CCX vs cuccaro-add!).
    (cuccaro-add-from-zero! c a-reg acc-reg cin-reg cin-idx n+1)
    ;; (2) cadd(acc[n], f, acc[:lsbs]) — fires unchanged.
    (cadd-const! c acc-reg lsbs pmersenne-f
                 acc-reg n cin-reg cin-idx tmp-reg)
    ;; (3) Uncompute acc[n] via MSB comparator — fires unchanged.
    (cond
      (*dgcd-apply-boundary-conditional-replay*
       (let ((phase-bit (* 5 n+1)))
         (gate-hmr! c acc-reg n phase-bit)
         (cmp-lt-phase-conditioned-with-cin!
           c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
           cin-reg cin-idx
           acc-reg n
           phase-bit
           tmp-reg 0 (* 3 n+1))))
      (*cuccaro-use-borrowed*
       (cmp-lt-into-fast-offset!
         c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
         acc-reg n cin-reg cin-idx
         tmp-reg 0 (* 3 n+1)))
      (else
       (cmp-lt-into-offset!
         c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
         acc-reg n cin-reg cin-idx)))))

;;; ── mod-add-from-zero! — caller-explicit acc=|0> specialization ───
;;;
;;; Port of HEAD's `mod_add_qq_fast_from_zero` (mod.rs:961-1038). When
;;; acc-reg is provably |0> on entry, the (n+1)-bit cuccaro add at
;;; step (1) reduces to (n+1) CX-copies. Steps (2)-(8) fire unchanged
;;; — the addend a may exceed p, so the reduce-by-c path still must
;;; run. Saves n CCX per call vs full mod-add!.
;;;
;;; Caller responsibility:
;;;   - acc-reg MUST be |0> on entry across all n+1 bits.
;;;   - a-reg follows extended-reg convention (top bit |0>) — same as
;;;     mod-add!.
;;;
;;; Dispatches through pseudo-Mersenne or Solinas path mirroring
;;; mod-add!'s `cond`, so callers see uniform behavior under either
;;; lever stack.

(define (mod-add-from-zero! c a-reg acc-reg n+1 p
                            cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "acc := (acc + a) mod p WHEN acc is |0> on entry. n CCX saved vs
   mod-add!. See mod-add! header for parameter shape."
  (let* ((n        (- n+1 1))
         (c-const  (- (expt 2 n) p))
         (f-bits   (pmersenne-bit-length c-const))
         (padding  *mod-add-pseudo-mersenne-padding*))
    (cond
      ;; 2026-06-12 — DISABLED. mod-add-inplace-pseudo-mersenne-from-zero!
      ;; shares the same MSB-only-comparator pattern as the in-place
      ;; variant — step (2) cadd controlled on acc[n] misses sum ∈ [p, 2^n)
      ;; boundary. See commit 5e6e3af for full analysis.
      ;;
      ;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on,
      ;; the band detector classically peeks both operands & routes
      ;; pseudo-Mersenne only on safe inputs. Since acc-reg is provably
      ;; |0> on entry per the from-zero contract, the band detector
      ;; sees acc-cl = 0 → safe iff a-cl < p (the only relevant case).
      ((and *mod-add-use-pseudo-mersenne*
            (> c-const 0)
            (< (+ padding f-bits) n+1)
            (mod-add-alg-11-safe? c a-reg acc-reg n+1 p))
       (mod-add-inplace-pseudo-mersenne-from-zero!
         c a-reg acc-reg n+1 p c-const
         cin-reg cin-idx tmp-reg flag-reg flag-idx))
      (else
       ;; (1) CX-copy a into acc (saves n CCX vs cuccaro-add!).
       (cuccaro-add-from-zero! c a-reg acc-reg cin-reg cin-idx n+1)
       ;; (2) add-const c at n+1 bits — fires unchanged.
       (add-const!   c acc-reg n+1 c-const cin-reg cin-idx tmp-reg)
       ;; (3) flag := acc[n] (overflow bit).
       (gate-cx!     c acc-reg n flag-reg flag-idx)
       ;; (4) X flag.
       (gate-x!      c flag-reg flag-idx)
       ;; (5) csub c controlled on flag.
       (csub-const!  c acc-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg)
       ;; (6) X flag back.
       (gate-x!      c flag-reg flag-idx)
       ;; (7) CX flag -> acc[n] — clear top bit when flag=1.
       (gate-cx!     c flag-reg flag-idx acc-reg n)
       ;; (8) Uncompute flag via cmp-lt: flag ^= (acc < a).
       (cond
         (*cuccaro-use-borrowed*
          ;; 2026-06-12 H7a-third-defect probe: replace constant (* 3 n+1)
          ;; bit-base with cas-alloc counter — same defect class as cdtf.
          (cmp-lt-into-fast! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx
                             tmp-reg 0 (cas-alloc-bit-base! n)))
         (else
          (cmp-lt-into! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx)))))))

;;; ── inverses of add-const / csub-const (needed by mod-sub!) ────
;;;
;;; sub-const!  = inverse of add-const!  (unconditional subtract of k)
;;; cadd-const! = inverse of csub-const! (controlled add of k)
;;;
;;; Pattern mirrors add-const/csub-const: load classical k into tmp via
;;; (c)load-const, run cuccaro-(sub|add), unload. load/unload self-inverse.

(define (sub-const! c acc-reg n k cin-reg cin-idx tmp-reg)
  "acc := (acc - k) mod 2^n. tmp must be width-n at |0>."
  (let ((kk (modulo k (expt 2 n))))
    (load-const!   c tmp-reg n kk)
    (cuccaro-sub!  c tmp-reg acc-reg cin-reg cin-idx n)
    (unload-const! c tmp-reg n kk)))

;;; ── sweep-050 direct sparse-constant cadd / csub primitives ────
;;;
;;; *cadd-direct-trunc-fast* — sweep-050 lever. Port of HEAD's
;;; cadd_nbit_const_direct_trunc_fast (const_arith.rs:487-568) and the
;;; matching csub_nbit_const_direct_trunc_fast (const_arith.rs:574-654).
;;;
;;; When #t, cadd-const! / csub-const! dispatch to the direct path:
;;; for each nonzero bit i of k, a forward carry/borrow sweep emits
;;; 3-CCX maj (or 2-CCX+2-CX with fold_maj2 when *cuccaro-maj2* on)
;;; into a fresh carries ancilla. Carry-tail truncated at
;;; min(n-2, highest_set_bit(k) + window). Sum bits via CX. Backward
;;; sweep measurement-uncomputes carries via HMR + CZ_if triplet.
;;;
;;; Saves ~one cload + one cuccaro-add + one cunload per call vs the
;;; generic cload/cuccaro-add/cunload path. Predicted 2-4 % full-stack
;;; Toffoli when stacked with *cuccaro-maj2*.
;;;
;;; *cadd-direct-window* — carry-tail safety window (mirrors HEAD's
;;; `window` parameter). Higher window → smaller truncation flake
;;; probability ~2^-(window+1) per call; HEAD's default 8.

(define *cadd-direct-trunc-fast* #f)
(define *cadd-direct-window* 8)

;;; *cuccaro-maj2* — sweep-047 lever for fold_maj2 inside the direct
;;; primitives. Defensively defined here so a champion cell can set it
;;; even if sweep-047 hasn't landed its own define yet. When #t, each
;;; full-MAJ (3 CCX) becomes a maj2 fold (2 CCX + 2 CX) inside the
;;; direct path.

(define *cuccaro-maj2* #f)

;;; *cadd-direct-bit-base* — classical-bit base offset used by HMR
;;; uncompute inside the direct primitives. Each call consumes
;;; (last+1) consecutive bit IDs starting at this base.
;;;
;;; 2026-06-12 — H7a peel-8 (commit 648d78e) ROOT-CAUSED back-to-back
;;; mod-add composition wrong-output to constant-bit-base reuse across
;;; consecutive cadd-const!/csub-const! calls. The prior claim "reuse
;;; across separate calls is safe (push-cond/pop-cond brackets every
;;; cz_if)" turned out wrong under cumulative kaliski-body state.
;;; Sweep-doctrine reducers test-mca-bisect-precursor + peel-8 toggle
;;; demonstrate the collision flips the second sum by 2^top-set-bit(k).
;;;
;;; Fix: monotonic counter (*cadd-direct-bit-base-next*) advances
;;; per-call by `n+1` so each direct call gets a unique non-overlapping
;;; slot range. *cadd-direct-bit-base* preserved for back-compat (read
;;; as the floor; never mutated directly). cdtf-alloc-bit-base!(n)
;;; returns the next slot.

(define *cadd-direct-bit-base* 400000)
(define *cadd-direct-bit-base-next* 400000)

(define (cdtf-alloc-bit-base! n)
  "Return a fresh non-overlapping classical-bit base for one cdtf call.
   Advances *cadd-direct-bit-base-next* by (n+1) so each call's HMR slots
   live in their own [b, b+n] range. n is the width passed to the direct
   primitive — must reserve at least n+1 consecutive IDs."
  (let ((b *cadd-direct-bit-base-next*))
    (set! *cadd-direct-bit-base-next* (+ b n 1))
    b))

(define (highest-set-bit k)
  "Index (0-based) of the highest set bit of positive integer k.
   highest-set-bit(0)=0 (caller guards via popcount > 0)."
  (let loop ((i 0) (m k))
    (cond
      ((= m 0) (if (= i 0) 0 (- i 1)))
      (else    (loop (+ i 1) (quotient m 2))))))

;;; ── cadd/csub_nbit_const_direct_fast (sweep-cadd-csub-direct-fast)
;;;
;;; HEAD const_arith.rs:65 csub_nbit_const_direct_fast
;;;      const_arith.rs:152 cadd_nbit_const_direct_fast
;;;
;;; Closes AUDIT §8 rows 203 (direct-fast pair, non-truncated). The
;;; truncated variants (-trunc-fast) already ported below.
;;;
;;; "Direct" = no auxiliary loaded-constant register. Skips the n-qubit
;;; register at Kaliski halve peaks; for sparse secp256k1 c=2^32+977
;;; CCX count essentially unchanged vs auxiliary-register path but
;;; peak qubits drop by n.
;;;
;;; Pattern (per HEAD lines 65-131 sub, 152-217 add):
;;;   1. carries/borrows register: alloc n-1 ancillas
;;;   2. forward carry/borrow sweep — CCX on majority recurrence,
;;;      gated on bit(k,i) sparsity
;;;   3. sum/difference bits: cx(ctrl, acc[i]) when bit(k,i); cx
;;;      carry into acc
;;;   4. measurement-uncompute carries in reverse — HMR + cz_if pattern
;;;      per Gidney 2025
;;;
;;; Caller responsibility:
;;;   acc-reg : data register width n
;;;   ctrl-reg/ctrl-idx : control bit
;;;   carries-reg : (n-1)-wide clean ancilla register; restored
;;;   bit-base : classical bit-id base for HMR (uses n-1 bits)

(define (cadd-nbit-const-direct-fast!
          c acc-reg n k ctrl-reg ctrl-idx carries-reg bit-base)
  "Port of HEAD cadd_nbit_const_direct_fast (const_arith.rs:152).
   acc += (ctrl ? k : 0) mod 2^n via direct carry sweep + HMR uncompute."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (when (bit-set? k 0) (gate-cx! c ctrl-reg ctrl-idx acc-reg 0)))
    (else
     ;; Forward carry sweep
     (let loop-fwd ((i 0))
       (when (< i (- n 1))
         (let ((target  (cons carries-reg i))
               (has-cin (> i 0)))
           (cond
             ((bit-set? k i)
              (cond
                (has-cin
                 (gate-ccx! c acc-reg i carries-reg (- i 1) carries-reg i)
                 (gate-ccx! c ctrl-reg ctrl-idx acc-reg i carries-reg i)
                 (gate-ccx! c ctrl-reg ctrl-idx carries-reg (- i 1) carries-reg i))
                (else
                 (gate-ccx! c acc-reg i ctrl-reg ctrl-idx carries-reg i))))
             (has-cin
              (gate-ccx! c acc-reg i carries-reg (- i 1) carries-reg i))))
         (loop-fwd (+ i 1))))
     ;; Sum bits
     (let loop-sum ((i 0))
       (when (< i n)
         (when (bit-set? k i)
           (gate-cx! c ctrl-reg ctrl-idx acc-reg i))
         (when (> i 0)
           (gate-cx! c carries-reg (- i 1) acc-reg i))
         (loop-sum (+ i 1))))
     ;; Measurement-uncompute carries (reverse). For ADDITION the
     ;; identity is carry_{i+1} = majority(!acc_i_final, k_i, carry_i)
     ;; — note the X on acc[i] around the cz_if pairs.
     (let loop-back ((i (- n 2)))
       (when (>= i 0)
         (let ((bit-id  (+ bit-base i))
               (has-cin (> i 0)))
           (gate-hmr! c carries-reg i bit-id)
           (cond
             ((bit-set? k i)
              (gate-x! c acc-reg i)
              (cond
                (has-cin
                 (gate-push-cond! c bit-id)
                 (gate-cz! c acc-reg i ctrl-reg ctrl-idx)
                 (gate-pop-cond! c)
                 (gate-push-cond! c bit-id)
                 (gate-cz! c acc-reg i carries-reg (- i 1))
                 (gate-pop-cond! c)
                 (gate-x! c acc-reg i)
                 (gate-push-cond! c bit-id)
                 (gate-cz! c ctrl-reg ctrl-idx carries-reg (- i 1))
                 (gate-pop-cond! c))
                (else
                 (gate-push-cond! c bit-id)
                 (gate-cz! c acc-reg i ctrl-reg ctrl-idx)
                 (gate-pop-cond! c)
                 (gate-x! c acc-reg i))))
             (has-cin
              (gate-x! c acc-reg i)
              (gate-push-cond! c bit-id)
              (gate-cz! c acc-reg i carries-reg (- i 1))
              (gate-pop-cond! c)
              (gate-x! c acc-reg i))))
         (loop-back (- i 1)))))))

(define (csub-nbit-const-direct-fast!
          c acc-reg n k ctrl-reg ctrl-idx borrows-reg bit-base)
  "Port of HEAD csub_nbit_const_direct_fast (const_arith.rs:65).
   acc -= (ctrl ? k : 0) mod 2^n via direct borrow sweep + HMR uncompute."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (when (bit-set? k 0) (gate-cx! c ctrl-reg ctrl-idx acc-reg 0)))
    (else
     ;; Forward borrow sweep. borrow_{i+1} = majority(!acc_i, k_i, borrow_i).
     (let loop-fwd ((i 0))
       (when (< i (- n 1))
         (let ((has-bin (> i 0)))
           (cond
             ((bit-set? k i)
              (gate-x! c acc-reg i)
              (cond
                (has-bin
                 (gate-ccx! c acc-reg i borrows-reg (- i 1) borrows-reg i)
                 (gate-ccx! c ctrl-reg ctrl-idx acc-reg i borrows-reg i)
                 (gate-ccx! c ctrl-reg ctrl-idx borrows-reg (- i 1) borrows-reg i))
                (else
                 (gate-ccx! c acc-reg i ctrl-reg ctrl-idx borrows-reg i)))
              (gate-x! c acc-reg i))
             (has-bin
              (gate-x! c acc-reg i)
              (gate-ccx! c acc-reg i borrows-reg (- i 1) borrows-reg i)
              (gate-x! c acc-reg i))))
         (loop-fwd (+ i 1))))
     ;; Difference bits: acc_i ^= k_i ^ borrow_i.
     (let loop-diff ((i 0))
       (when (< i n)
         (when (bit-set? k i)
           (gate-cx! c ctrl-reg ctrl-idx acc-reg i))
         (when (> i 0)
           (gate-cx! c borrows-reg (- i 1) acc-reg i))
         (loop-diff (+ i 1))))
     ;; Measurement-uncompute borrows. For SUBTRACTION the post-sum
     ;; identity is borrow_{i+1} = majority(acc_i_final, k_i, borrow_i).
     ;; No X bracketing around acc[i] (different from add).
     (let loop-back ((i (- n 2)))
       (when (>= i 0)
         (let ((bit-id  (+ bit-base i))
               (has-bin (> i 0)))
           (gate-hmr! c borrows-reg i bit-id)
           (cond
             ((bit-set? k i)
              (cond
                (has-bin
                 (gate-push-cond! c bit-id)
                 (gate-cz! c acc-reg i ctrl-reg ctrl-idx)
                 (gate-pop-cond! c)
                 (gate-push-cond! c bit-id)
                 (gate-cz! c acc-reg i borrows-reg (- i 1))
                 (gate-pop-cond! c)
                 (gate-push-cond! c bit-id)
                 (gate-cz! c ctrl-reg ctrl-idx borrows-reg (- i 1))
                 (gate-pop-cond! c))
                (else
                 (gate-push-cond! c bit-id)
                 (gate-cz! c acc-reg i ctrl-reg ctrl-idx)
                 (gate-pop-cond! c))))
             (has-bin
              (gate-push-cond! c bit-id)
              (gate-cz! c acc-reg i borrows-reg (- i 1))
              (gate-pop-cond! c))))
         (loop-back (- i 1)))))))

(define (cadd-nbit-const-direct-trunc-fast!
         c acc-reg n k ctrl-reg ctrl-idx tmp-reg window bit-base)
  "acc[0..n) += (ctrl ? k : 0), carry-tail truncated.
   Port of HEAD cadd_nbit_const_direct_trunc_fast (const_arith.rs:487-568).

   acc-reg : (>=n)-wide quantum register holding the running accumulator.
   n       : slice width (>=1). Must not overlap with ctrl-reg/ctrl-idx.
   k       : compile-time classical integer; only its low n bits read.
   ctrl-reg, ctrl-idx : the qubit controlling the add (must not alias
                       any of acc-reg[0..n)).
   tmp-reg : (>=last+1)-wide ancilla register at |0>. Borrowed as the
             carries lane (acc-reg's tmp slot is wide enough for every
             pseudo-Mersenne caller in our stack).
   window  : carry-tail safety bits past highest_set_bit(k). HEAD's
             default 8; flake prob ~2^-(window+1).
   bit-base: classical-bit base offset; consumes [bit-base, bit-base+last]
             via HMR. Caller picks a non-colliding region.

   Returns tmp-reg[0..last] to |0> via HMR + cz_if; acc-reg gets
   updated sum; ctrl-reg unchanged."
  (let ((kk (modulo k (expt 2 n))))
    (cond
      ((= n 0) #t)
      ((= n 1)
       (when (bit-set? kk 0)
         (gate-cx! c ctrl-reg ctrl-idx acc-reg 0)))
      ((= kk 0) #t)
      (else
       (let* ((hi   (highest-set-bit kk))
              (last (min (- n 2) (+ hi window)))
              (maj2 *cuccaro-maj2*))
         ;; Forward carry sweep, truncated at `last`.
         (let loop ((i 0))
           (when (<= i last)
             (let ((carry-in? (> i 0)))
               (cond
                 ((bit-set? kk i)
                  (cond
                    (carry-in?
                     (cond
                       (maj2
                        (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
                        (gate-cx!  c acc-reg i tmp-reg (- i 1))
                        (gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i)
                        (gate-cx!  c acc-reg i tmp-reg (- i 1)))
                       (else
                        (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
                        (gate-ccx! c ctrl-reg ctrl-idx acc-reg i tmp-reg i)
                        (gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i))))
                    (else
                     (gate-ccx! c acc-reg i ctrl-reg ctrl-idx tmp-reg i))))
                 (carry-in?
                  (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i))))
             (loop (+ i 1))))
         ;; Sum bits: acc_i ^= k_i ^ carry_{i-1}; carries above last are 0.
         (let loop ((i 0))
           (when (< i n)
             (when (bit-set? kk i)
               (gate-cx! c ctrl-reg ctrl-idx acc-reg i))
             (when (and (> i 0) (<= (- i 1) last))
               (gate-cx! c tmp-reg (- i 1) acc-reg i))
             (loop (+ i 1))))
         ;; Backward measurement-uncompute carries (HMR + cz_if triplet).
         (let loop-back ((i last))
           (when (>= i 0)
             (let ((m         (+ bit-base i))
                   (carry-in? (> i 0)))
               (gate-hmr! c tmp-reg i m)
               (cond
                 ((bit-set? kk i)
                  (gate-x! c acc-reg i)
                  (cond
                    (carry-in?
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i ctrl-reg ctrl-idx)
                     (gate-pop-cond!  c)
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i tmp-reg (- i 1))
                     (gate-pop-cond!  c)
                     (gate-x! c acc-reg i)
                     (gate-push-cond! c m)
                     (gate-cz!        c ctrl-reg ctrl-idx tmp-reg (- i 1))
                     (gate-pop-cond!  c))
                    (else
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i ctrl-reg ctrl-idx)
                     (gate-pop-cond!  c)
                     (gate-x! c acc-reg i))))
                 (carry-in?
                  (gate-x! c acc-reg i)
                  (gate-push-cond! c m)
                  (gate-cz!        c acc-reg i tmp-reg (- i 1))
                  (gate-pop-cond!  c)
                  (gate-x! c acc-reg i))))
             (loop-back (- i 1)))))))))

(define (csub-nbit-const-direct-trunc-fast!
         c acc-reg n k ctrl-reg ctrl-idx tmp-reg window bit-base)
  "acc[0..n) -= (ctrl ? k : 0), borrow-tail truncated.
   Port of HEAD csub_nbit_const_direct_trunc_fast (const_arith.rs:574-654).
   Same calling convention as cadd-nbit-const-direct-trunc-fast!."
  (let ((kk (modulo k (expt 2 n))))
    (cond
      ((= n 0) #t)
      ((= n 1)
       (when (bit-set? kk 0)
         (gate-cx! c ctrl-reg ctrl-idx acc-reg 0)))
      ((= kk 0) #t)
      (else
       (let* ((hi   (highest-set-bit kk))
              (last (min (- n 2) (+ hi window)))
              (maj2 *cuccaro-maj2*))
         ;; Forward borrow sweep, truncated at `last`.
         (let loop ((i 0))
           (when (<= i last)
             (let ((borrow-in? (> i 0)))
               (cond
                 ((bit-set? kk i)
                  (gate-x! c acc-reg i)
                  (cond
                    (borrow-in?
                     (cond
                       (maj2
                        (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
                        (gate-cx!  c acc-reg i tmp-reg (- i 1))
                        (gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i)
                        (gate-cx!  c acc-reg i tmp-reg (- i 1)))
                       (else
                        (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
                        (gate-ccx! c ctrl-reg ctrl-idx acc-reg i tmp-reg i)
                        (gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i))))
                    (else
                     (gate-ccx! c acc-reg i ctrl-reg ctrl-idx tmp-reg i)))
                  (gate-x! c acc-reg i))
                 (borrow-in?
                  (gate-x! c acc-reg i)
                  (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
                  (gate-x! c acc-reg i))))
             (loop (+ i 1))))
         ;; Difference bits.
         (let loop ((i 0))
           (when (< i n)
             (when (bit-set? kk i)
               (gate-cx! c ctrl-reg ctrl-idx acc-reg i))
             (when (and (> i 0) (<= (- i 1) last))
               (gate-cx! c tmp-reg (- i 1) acc-reg i))
             (loop (+ i 1))))
         ;; Backward measurement-uncompute borrows.
         (let loop-back ((i last))
           (when (>= i 0)
             (let ((m          (+ bit-base i))
                   (borrow-in? (> i 0)))
               (gate-hmr! c tmp-reg i m)
               (cond
                 ((bit-set? kk i)
                  (cond
                    (borrow-in?
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i ctrl-reg ctrl-idx)
                     (gate-pop-cond!  c)
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i tmp-reg (- i 1))
                     (gate-pop-cond!  c)
                     (gate-push-cond! c m)
                     (gate-cz!        c ctrl-reg ctrl-idx tmp-reg (- i 1))
                     (gate-pop-cond!  c))
                    (else
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i ctrl-reg ctrl-idx)
                     (gate-pop-cond!  c))))
                 (borrow-in?
                  (gate-push-cond! c m)
                  (gate-cz!        c acc-reg i tmp-reg (- i 1))
                  (gate-pop-cond!  c))))
             (loop-back (- i 1)))))))))

;;; ── sweep-060 per-position-controls primitives ────────────────────
;;;
;;; Port of HEAD's cadd_per_position_controls_trunc /
;;; csub_per_position_controls_trunc (const_arith.rs:657-814).
;;;
;;; Unlike cadd-nbit-const-direct-trunc-fast! the "constant" k is NOT a
;;; compile-time scalar. Instead each position carries its own runtime
;;; qubit control kctrl[i] — possibly absent. The 3-CCX maj cluster
;;; operates on (acc[i], kctrl[i], carry_in). With *perpos-maj2* on,
;;; substitute 2-CCX + 2-CX ancilla-free majority (per HEAD's
;;; perpos_maj2_enabled() doc at const_arith.rs:449-466).
;;;
;;; lumbda representation of the per-position-controls vector:
;;;   list of length <= n where each element is either
;;;     - #f               -> no control at this position (k_i = 0)
;;;     - (reg . idx)      -> runtime control qubit at this position
;;;   Positions beyond list length default to #f (no control).
;;;
;;; The `last` argument is the inclusive truncation index for the
;;; carry/borrow sweep (mirrors HEAD's `last: usize`). Caller computes
;;; last = min(n-2, highest-controlled-position + window) so positions
;;; above `last` get carries assumed 0. Flake probability identical to
;;; HEAD's truncated direct adder.
;;;
;;; *perpos-maj2* — sweep-060 lever. When #t, the 3-CCX maj inside the
;;; per-pos-controls primitives substitutes the 2-CCX + 2-CX
;;; ancilla-free pattern. Default #f (3-CCX safe baseline).

(define *perpos-maj2* #f)

;;; ── HEAD modular-tier lever family (sweep-modular-lever-flags) ────
;;;
;;; Closes AUDIT §6 / §8 rows 217-218, 248-249, 260-261, 263.
;;; All default-OFF flag declarations covering HEAD's modular-tier
;;; configure_ecdsafail_submission_route lever surface.

;; *fold-maj2* — sibling of *perpos-maj2*. HEAD mod.rs:471
;; fold_maj2_enabled. The 2-CCX + 2-CX ancilla-free maj substitution
;; inside fold_carry path. Default #f.
(define *fold-maj2* #f)

;; ── HEAD fold substrate family (const_arith.rs:9-1267) ──
;; Wires the 4 fold-stage knobs that HEAD's submission route enables.
;; Port covers `fold_postsum_carry_phase_uncompute`,
;; `fold_postsum_carry_compute`, `emit_fold_maj1`/`emit_fold_majority`,
;; `fold_park_low_carries`, `fold_ripple_freed_tail_ed`.
;;
;; *fold-maj1* — HEAD const_arith.rs:9 fold_maj1_enabled. When #t AND
;; the four maj inputs (a, k, carry, target) are all-distinct qubits,
;; substitute the 4-CX + 1-CCX maj1 emit (saves 2 Toffoli vs the
;; 3-CCX baseline, costs 4 CX). Coexists with *fold-maj2*; maj1 wins
;; when applicable. Default #f. Already declared in
;; head-route-missing-flags.lsp; consumed here in the fold dispatch.

;; *fold-park-low-carries* — integer count of low carries to park via
;; HMR + cz_if phase-uncompute mid-ripple (mirrors HEAD's
;; fold_park_low_carries() return). Range [0, hi_delta]. Default 0
;; (no parking). When > 0, drops the fused double/halve high-water by
;; `park` qubits at cost of `park` extra HMR + cz_if pairs (phase-exact;
;; 0 Toffoli). Caller sets via `(set! *fold-park-low-carries* N)`.
(define *fold-park-low-carries* 0)

;; *fold-freed-tail* — HEAD const_arith.rs:867 fold_freed_tail_enabled.
;; When #t, switch the fused-fold ripple to the split-lane variant:
;; alloc `low[0..=hi_delta]` first, run active region, free the four
;; derived controls (h, xed, eord, n10), THEN alloc `tail` for the
;; wide high tail. Drops the wide-tail high-water by 4 ancillae (the
;; 4 derived controls released before the tail allocation peak).
;; Value/phase-EXACT vs the unsplit ripple. Default #f.
(define *fold-freed-tail* #f)
;; Backwards-compat alias for the `dgcd-` namespaced variant declared
;; in head-route-missing-flags.lsp — when either flag is set, the
;; freed-tail dispatch fires (consumer: cadd-2-controls-trunc-fast!).
;; *fold-freed-tail-ed* extends the freed-tail to ALSO release e,d
;; across the wide high tail (HYP-6 §4a). HEAD: -2 ancillae more.
;; Lumbda: STRUCTURAL NO-OP. The freed-tail dispatcher's caller-side
;; `e`/`d` are NOT separately allocated qubits in lumbda — the
;; `cadd-2-controls-trunc-fast!` dispatcher binds `e ↔ ctrl1-reg/idx`
;; and `d ↔ ctrl2-reg/idx` directly (mod-arith.lsp:2750-2755 docstring).
;; mod-4x-inplace! passes ovf1/ovf2 themselves as ctrl1/ctrl2, exploiting
;; the s2=1 classical specialization (s2 is a classical-true constant
;; under lumbda's K=2 host emit, never a qubit). Per HEAD compressed.rs
;; :3260-3271 the e,d copy alloc is `d = ovf1 & s2; e = ovf1 ^ d ^ ovf2`
;; — under s2=1 collapses to `d = ovf1; e = ovf2`. Lumbda skipped this
;; copy-alloc structurally, so it has nothing extra to free across the
;; tail. The -2 ancilla win HEAD reports is already-banked at the
;; substrate level. See test-fold-freed-tail-ed-port.lsp for the
;; positive-control reducer that proves byte-identity for flag-ON vs
;; flag-OFF + identical peak-qubits + identical toffoli counts.

;; *double-carry-trunc-window* — HEAD mod.rs:427
;; double_carry_trunc_window. KAL_DOUBLE_CARRY_TRUNC_W from
;; configure_ecdsafail_submission_route (=20 in HEAD's tuned route).
;; Integer truncation width for double-carry path; 0 = OFF.
(define *double-carry-trunc-window* 0)

;; *fold-carry-trunc-window* — HEAD mod.rs:442
;; fold_carry_trunc_window. KAL_FOLD_CARRY_TRUNC_W from
;; configure_ecdsafail_submission_route (=20 in HEAD). 0 = OFF.
(define *fold-carry-trunc-window* 0)

;; *mod-add-qq-vent* — HEAD mod.rs:189 mod_add_qq_vent.
;; KAL_VENT_MODADD lever; vent-based mod-add saves overflow ancilla
;; in Kaliski loop body. Default #f.
(define *mod-add-qq-vent* #f)

;; *mod-sub-qq-vent* — HEAD mod.rs:250 mod_sub_qq_vent. Symmetric.
(define *mod-sub-qq-vent* #f)

;; *mod-add-qq-fast-from-zero* — HEAD mod.rs:961
;; mod_add_qq_fast_from_zero. Initial-state-known optimization;
;; saves the cin walk when acc is provably |0> on entry. Default #f.
(define *mod-add-qq-fast-from-zero* #f)

;; *cmod-double-inplace-lazy* — HEAD mod.rs:817 cmod_double_inplace_lazy.
;; Controlled lazy form of mod_double_inplace_fast; used inside HEAD's
;; apply-bitvector chunked path. Default #f.
(define *cmod-double-inplace-lazy* #f)

;; *cmod-halve-inplace-lazy* — HEAD mod.rs:841. Symmetric. Default #f.
(define *cmod-halve-inplace-lazy* #f)

;; *mod-shift-left-by-k-lowq* — HEAD mod.rs:618. lowq variant of
;; mod_shift_left_by_k. Default #f.
(define *mod-shift-left-by-k-lowq* #f)

;; *mod-shift-right-by-k-lowq* — HEAD mod.rs:678. Symmetric. Default #f.
(define *mod-shift-right-by-k-lowq* #f)

;; ── extcarry_clean family — HEAD const_arith.rs:239-331 ──
;;
;; Six default-OFF flags covering the clean-extcarry adder primitives
;; HEAD uses when MSB is provably zero. All flags gate variant dispatch
;; at the const-arith callsite (downstream substrate work).

(define *add-nbit-const-extcarry-clean*           #f)
(define *add-nbit-const-extcarry-clean-with-cin*  #f)
(define *sub-nbit-const-extcarry-clean*           #f)
(define *cadd-nbit-const-extcarry-clean*          #f)
(define *csub-nbit-const-extcarry-clean*          #f)
(define *csub-nbit-const-extcarry-clean-with-cin* #f)

;; ── direct-fast variants — HEAD const_arith.rs:65,152 ──
;;
;; cadd_nbit_const_direct_fast / csub_nbit_const_direct_fast — the
;; DIRECT_CONST_WALKS path. *cadd-direct-trunc-fast* (truncated
;; variant) already PORTED; these flag the non-truncated DIRECT_CONST
;; siblings. Default #f.

(define *cadd-nbit-const-direct-fast* #f)
(define *csub-nbit-const-direct-fast* #f)

;; *csub-per-position-controls-trunc* — sibling of
;; cadd-per-position-controls-trunc! (already ported as lumbda
;; primitive). Flag declaration here for variant dispatch. Default #f.

(define *csub-per-position-controls-trunc* #f)

;;; *kaliski-use-per-pos-controls* — sweep-060 lever. When #t, host
;;; kaliski iteration's apply-phase callsite dispatches into
;;; cadd-per-position-controls-trunc! instead of the compile-time
;;; constant adder. Default #f — substrate gap means no callsite
;;; consumes this lever yet (see RESULTS.md for the apply-phase
;;; roadmap). Defensive flag definition so champion cells can set it
;;; without redefinition errors.

(define *kaliski-use-per-pos-controls* #f)

(define (perpos-ctrl-at controls i)
  "Return the per-position control pair at index i, or #f. Out-of-range
   defaults to #f (no control)."
  (cond
    ((null? controls) #f)
    ((<= i -1)        #f)
    (else
     (let loop ((lst controls) (j 0))
       (cond
         ((null? lst) #f)
         ((= j i)     (car lst))
         (else        (loop (cdr lst) (+ j 1))))))))

(define (perpos-ctrls-length controls)
  "Length of the per-position-controls list."
  (let loop ((lst controls) (n 0))
    (cond
      ((null? lst) n)
      (else        (loop (cdr lst) (+ n 1))))))

(define (cadd-per-position-controls-trunc!
         c acc-reg n controls last tmp-reg bit-base)
  "acc[0..n) += sum_{i where ctrl_i present} (ctrl_i ? 2^i : 0),
   carry-tail truncated at index `last` (inclusive).

   Port of HEAD cadd_per_position_controls_trunc (const_arith.rs:657-735).

   acc-reg  : (>=n)-wide quantum register holding the running accumulator.
   n        : slice width (>=1). Must not overlap any control qubit.
   controls : list of length <= n of either #f or (reg . idx) pairs.
              Position i: ctrl_i = (perpos-ctrl-at controls i). If #f,
              position contributes 0; else contributes 2^i conditioned on
              that ctrl qubit.
   last     : inclusive truncation index for the carry sweep. Must
              satisfy 0 <= last < n. Caller picks last = min(n-2,
              highest-active-pos + window). Carries above `last` assumed 0.
   tmp-reg  : (>=last+1)-wide ancilla register at |0> for the carries lane.
   bit-base : classical-bit base offset. Consumes [bit-base,
              bit-base+last] via HMR during measurement-uncompute.

   When *perpos-maj2* #t, each 3-CCX maj substitutes 2-CCX + 2-CX
   ancilla-free majority (target ^= maj(acc,carry_in,kc) emitted as
   ccx(acc,ci,target); cx(acc,ci); ccx(kc,ci,target); cx(acc,ci)).

   Returns tmp-reg[0..last] to |0> via HMR + cz_if; acc-reg gets sum
   updated; every kctrl unchanged."
  (cond
    ((= n 0) #t)
    ((<= last -1) #t)
    (else
     (let ((maj2 *perpos-maj2*)
           (ctrl-len (perpos-ctrls-length controls)))
       ;; Defensive: last must be < n.
       (when (>= last n)
         (error "cadd-per-position-controls-trunc!: last >= n"
                last n))
       ;; Forward carry sweep, truncated at `last`.
       ;; carry_i = maj(acc_i, kctrl_i, carry_{i-1}) when both kc + ci
       ;; present; lower-order branches when one is absent.
       (let loop ((i 0))
         (when (<= i last)
           (let* ((kc        (perpos-ctrl-at controls i))
                  (carry-in? (> i 0)))
             (cond
               (kc
                (let ((kc-reg (car kc))
                      (kc-idx (cdr kc)))
                  (cond
                    (carry-in?
                     ;; *fold-maj1* (when on AND inputs distinct) wraps to
                     ;; 4-CX + 1-CCX maj1 (saves 2 Toff/pos); else falls
                     ;; through to maj2 (2-CCX + 2-CX) when caller set
                     ;; maj2 #t; else 3-CCX baseline. Byte-identical when
                     ;; *fold-maj1* off — emit-fold-majority!'s maj2/3-CCX
                     ;; branches match the prior inline gate sequence.
                     (emit-fold-majority! c
                       acc-reg i        ; a (acc[i])
                       kc-reg  kc-idx   ; k (kctrl_i)
                       tmp-reg (- i 1)  ; ci (carry_{i-1})
                       tmp-reg i        ; target (carry_i)
                       maj2))
                    (else
                     (gate-ccx! c acc-reg i kc-reg kc-idx tmp-reg i)))))
               (carry-in?
                (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i))))
           (loop (+ i 1))))
       ;; Sum bits: acc_i ^= kctrl_i ^ carry_{i-1}; carries above last 0.
       (let loop ((i 0))
         (when (< i n)
           (let ((kc (perpos-ctrl-at controls i)))
             (when kc
               (gate-cx! c (car kc) (cdr kc) acc-reg i))
             (when (and (> i 0) (<= (- i 1) last))
               (gate-cx! c tmp-reg (- i 1) acc-reg i))
             (loop (+ i 1)))))
       ;; Backward measurement-uncompute carries via HMR + cz_if.
       (let loop-back ((i last))
         (when (>= i 0)
           (let ((m         (+ bit-base i))
                 (kc        (perpos-ctrl-at controls i))
                 (carry-in? (> i 0)))
             (gate-hmr! c tmp-reg i m)
             (cond
               (kc
                (let ((kc-reg (car kc))
                      (kc-idx (cdr kc)))
                  (gate-x! c acc-reg i)
                  (cond
                    (carry-in?
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i kc-reg kc-idx)
                     (gate-pop-cond!  c)
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i tmp-reg (- i 1))
                     (gate-pop-cond!  c)
                     (gate-x! c acc-reg i)
                     (gate-push-cond! c m)
                     (gate-cz!        c kc-reg kc-idx tmp-reg (- i 1))
                     (gate-pop-cond!  c))
                    (else
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i kc-reg kc-idx)
                     (gate-pop-cond!  c)
                     (gate-x! c acc-reg i)))))
               (carry-in?
                (gate-x! c acc-reg i)
                (gate-push-cond! c m)
                (gate-cz!        c acc-reg i tmp-reg (- i 1))
                (gate-pop-cond!  c)
                (gate-x! c acc-reg i))))
           (loop-back (- i 1))))))))

(define (csub-per-position-controls-trunc!
         c acc-reg n controls last tmp-reg bit-base)
  "acc[0..n) -= sum_{i where ctrl_i present} (ctrl_i ? 2^i : 0),
   borrow-tail truncated at index `last` (inclusive).

   Port of HEAD csub_per_position_controls_trunc (const_arith.rs:737-814).
   Same calling convention as cadd-per-position-controls-trunc!."
  (cond
    ((= n 0) #t)
    ((<= last -1) #t)
    (else
     (let ((maj2 *perpos-maj2*))
       (when (>= last n)
         (error "csub-per-position-controls-trunc!: last >= n"
                last n))
       ;; Forward borrow sweep, truncated at `last`.
       (let loop ((i 0))
         (when (<= i last)
           (let* ((kc         (perpos-ctrl-at controls i))
                  (borrow-in? (> i 0)))
             (cond
               (kc
                (let ((kc-reg (car kc))
                      (kc-idx (cdr kc)))
                  (gate-x! c acc-reg i)
                  (cond
                    (borrow-in?
                     ;; Symmetric to cadd-per-position-controls-trunc!.
                     ;; X-sandwich on acc[i] inverts the carry-sense to
                     ;; borrow; the inner maj is identical to the add
                     ;; variant. *fold-maj1* fires here too when inputs
                     ;; distinct. Byte-identical when *fold-maj1* off.
                     (emit-fold-majority! c
                       acc-reg i        ; a (acc[i] with X-sandwich)
                       kc-reg  kc-idx
                       tmp-reg (- i 1)
                       tmp-reg i
                       maj2))
                    (else
                     (gate-ccx! c acc-reg i kc-reg kc-idx tmp-reg i)))
                  (gate-x! c acc-reg i)))
               (borrow-in?
                (gate-x! c acc-reg i)
                (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
                (gate-x! c acc-reg i))))
           (loop (+ i 1))))
       ;; Difference bits: acc_i ^= kctrl_i ^ borrow_{i-1}.
       (let loop ((i 0))
         (when (< i n)
           (let ((kc (perpos-ctrl-at controls i)))
             (when kc
               (gate-cx! c (car kc) (cdr kc) acc-reg i))
             (when (and (> i 0) (<= (- i 1) last))
               (gate-cx! c tmp-reg (- i 1) acc-reg i))
             (loop (+ i 1)))))
       ;; Backward measurement-uncompute borrows.
       (let loop-back ((i last))
         (when (>= i 0)
           (let ((m          (+ bit-base i))
                 (kc         (perpos-ctrl-at controls i))
                 (borrow-in? (> i 0)))
             (gate-hmr! c tmp-reg i m)
             (cond
               (kc
                (let ((kc-reg (car kc))
                      (kc-idx (cdr kc)))
                  (cond
                    (borrow-in?
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i kc-reg kc-idx)
                     (gate-pop-cond!  c)
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i tmp-reg (- i 1))
                     (gate-pop-cond!  c)
                     (gate-push-cond! c m)
                     (gate-cz!        c kc-reg kc-idx tmp-reg (- i 1))
                     (gate-pop-cond!  c))
                    (else
                     (gate-push-cond! c m)
                     (gate-cz!        c acc-reg i kc-reg kc-idx)
                     (gate-pop-cond!  c)))))
               (borrow-in?
                (gate-push-cond! c m)
                (gate-cz!        c acc-reg i tmp-reg (- i 1))
                (gate-pop-cond!  c))))
           (loop-back (- i 1))))))))

;;; ── HEAD fold-substrate helpers (const_arith.rs:9-43, 911-987) ────
;;;
;;; Port of HEAD's fold-stage gate helpers. Used by both the baseline
;;; fused-fold ripple (when *fold-maj1* lifts maj inputs to maj1) and
;;; the freed-tail variant (which calls fold-postsum-carry-* directly
;;; for low-carry park / unpark).
;;;
;;; emit-fold-maj1!    : 4-CX + 1-CCX majority on 4 DISTINCT qubits.
;;;                      Saves 2 Toff vs the 3-CCX baseline; needs all
;;;                      4 inputs distinct (caller verifies).
;;; emit-fold-majority!: dispatch — fold-maj1 (if enabled + distinct),
;;;                      else maj2 (2 CCX + 2 CX), else 3-CCX baseline.
;;; fold-postsum-carry-phase-uncompute! : measurement-conditioned
;;;                      cz_if chain to un-park a parked carry (acc[i]
;;;                      ^= maj(...) inverse via cz_if instead of CCX).
;;; fold-postsum-carry-compute!        : symmetric compute-from-acc
;;;                      pass when re-parking after the tail uncompute.

(define (fold-maj1-inputs-distinct? a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx)
  "True iff all 4 (reg, idx) pairs are pairwise distinct. Matches HEAD's
   maj1_inputs_distinct (const_arith.rs:4)."
  (let ((pa (cons a-reg  a-idx))
        (pk (cons k-reg  k-idx))
        (pc (cons ci-reg ci-idx))
        (pt (cons tgt-reg tgt-idx)))
    (and (not (equal? pa pk))
         (not (equal? pa pc))
         (not (equal? pa pt))
         (not (equal? pk pc))
         (not (equal? pk pt))
         (not (equal? pc pt)))))

(define (emit-fold-maj1! c a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx)
  "4-CX + 1-CCX majority. tgt ^= maj(a, k, carry). HEAD const_arith.rs:13-21.
   Caller MUST ensure the 4 inputs are pairwise distinct."
  (gate-cx!  c ci-reg ci-idx tgt-reg tgt-idx)
  (gate-cx!  c ci-reg ci-idx a-reg   a-idx)
  (gate-cx!  c ci-reg ci-idx k-reg   k-idx)
  (gate-ccx! c a-reg  a-idx  k-reg   k-idx tgt-reg tgt-idx)
  (gate-cx!  c ci-reg ci-idx k-reg   k-idx)
  (gate-cx!  c ci-reg ci-idx a-reg   a-idx))

(define (emit-fold-majority! c a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx maj2)
  "Dispatch: if *fold-maj1* AND inputs distinct → maj1 (4 CX + 1 CCX);
   else if maj2 → 2-CCX + 2-CX ancilla-free; else 3-CCX baseline.
   Mirrors HEAD const_arith.rs:23-43 emit_fold_majority."
  (cond
    ((and *fold-maj1*
          (fold-maj1-inputs-distinct? a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx))
     (emit-fold-maj1! c a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx))
    (maj2
     ;; 2-CCX + 2-CX ancilla-free. tgt ^= maj(a, k, carry) via:
     ;;   ccx(a, ci, tgt); cx(a, ci); ccx(k, ci, tgt); cx(a, ci)
     (gate-ccx! c a-reg a-idx ci-reg ci-idx tgt-reg tgt-idx)
     (gate-cx!  c a-reg a-idx ci-reg ci-idx)
     (gate-ccx! c k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx)
     (gate-cx!  c a-reg a-idx ci-reg ci-idx))
    (else
     ;; 3-CCX baseline. tgt ^= maj(a, k, ci) = a·ci ⊕ k·a ⊕ k·ci.
     (gate-ccx! c a-reg a-idx ci-reg ci-idx tgt-reg tgt-idx)
     (gate-ccx! c k-reg k-idx a-reg  a-idx  tgt-reg tgt-idx)
     (gate-ccx! c k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx))))

(define (fold-postsum-carry-phase-uncompute!
          c acc-reg i kc-pair ci-pair m-bit is-add)
  "Phase-only carry uncompute via cz_if on a measured classical bit.
   acc-reg : accumulator quantum register.
   i       : current position (0..hi_delta).
   kc-pair : (reg . idx) of position-i control, or #f.
   ci-pair : (reg . idx) of carry_{i-1}, or #f (only at i=0).
   m-bit   : classical bit id holding HMR measurement of low[i].
   is-add  : #t for add, #f for sub (borrow).
   Mirrors HEAD const_arith.rs:911-948 fold_postsum_carry_phase_uncompute."
  (cond
    (is-add
     (cond
       (kc-pair
        (let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair)))
          (gate-x! c acc-reg i)
          (cond
            (ci-pair
             (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
               (gate-push-cond! c m-bit)
               (gate-cz!        c acc-reg i kc-reg kc-idx)
               (gate-pop-cond!  c)
               (gate-push-cond! c m-bit)
               (gate-cz!        c acc-reg i ci-reg ci-idx)
               (gate-pop-cond!  c)
               (gate-x!         c acc-reg i)
               (gate-push-cond! c m-bit)
               (gate-cz!        c kc-reg kc-idx ci-reg ci-idx)
               (gate-pop-cond!  c)))
            (else
             (gate-push-cond! c m-bit)
             (gate-cz!        c acc-reg i kc-reg kc-idx)
             (gate-pop-cond!  c)
             (gate-x!         c acc-reg i)))))
       (ci-pair
        (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
          (gate-x!         c acc-reg i)
          (gate-push-cond! c m-bit)
          (gate-cz!        c acc-reg i ci-reg ci-idx)
          (gate-pop-cond!  c)
          (gate-x!         c acc-reg i)))))
    (else
     (cond
       (kc-pair
        (let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair)))
          (cond
            (ci-pair
             (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
               (gate-push-cond! c m-bit)
               (gate-cz!        c acc-reg i kc-reg kc-idx)
               (gate-pop-cond!  c)
               (gate-push-cond! c m-bit)
               (gate-cz!        c acc-reg i ci-reg ci-idx)
               (gate-pop-cond!  c)
               (gate-push-cond! c m-bit)
               (gate-cz!        c kc-reg kc-idx ci-reg ci-idx)
               (gate-pop-cond!  c)))
            (else
             (gate-push-cond! c m-bit)
             (gate-cz!        c acc-reg i kc-reg kc-idx)
             (gate-pop-cond!  c)))))
       (ci-pair
        (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
          (gate-push-cond! c m-bit)
          (gate-cz!        c acc-reg i ci-reg ci-idx)
          (gate-pop-cond!  c)))))))

(define (fold-postsum-carry-compute!
          c acc-reg i kc-pair ci-pair tgt-reg tgt-idx is-add)
  "Symmetric Toffoli compute (re-park carry from post-sum acc). Used
   after the tail uncompute to re-derive the parked low carries.
   Mirrors HEAD const_arith.rs:950-987 fold_postsum_carry_compute."
  (cond
    (is-add
     (cond
       (kc-pair
        (let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair)))
          (gate-x! c acc-reg i)
          (cond
            (ci-pair
             (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
               (gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx)
               (gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx)
               (gate-x!   c acc-reg i)
               (gate-ccx! c kc-reg kc-idx ci-reg ci-idx tgt-reg tgt-idx)))
            (else
             (gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx)
             (gate-x!   c acc-reg i)))))
       (ci-pair
        (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
          (gate-x!   c acc-reg i)
          (gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx)
          (gate-x!   c acc-reg i)))))
    (else
     (cond
       (kc-pair
        (let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair)))
          (cond
            (ci-pair
             (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
               (gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx)
               (gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx)
               (gate-ccx! c kc-reg kc-idx ci-reg ci-idx tgt-reg tgt-idx)))
            (else
             (gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx)))))
       (ci-pair
        (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
          (gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx)))))))

;;; ── sweep-fused-fold-v25 — cadd-2-controls-trunc-fast! ────────────
;;;
;;; HEAD reference: `compressed.rs:2193-2215` (forward fused fold body of
;;; `dialog_gcd_fused_double_y`) — single truncated ripple at width lsbs
;;; emitting δ = k1·ctrl1 + k2·ctrl2 via the 12-position per-position
;;; controls table mapped to bits {0,1,4,5,6,7,8,9,10,11, hi, hi+1} for a
;;; secp256k1-class pseudo-Mersenne c.
;;;
;;; What V2.5 saves vs V2's two `cadd-const!` calls:
;;;
;;;   V2: cadd-const(v, lsbs, c, ctrl1) + cadd-const(v, lsbs, 2c, ctrl2)
;;;     → 2 × full Solinas truncated ripple. ~62 Toff/call × 2.
;;;
;;;   V2.5: derive 4 ancilla controls (h, xed, eord, n10) via 3 CCX + 6 CX,
;;;     issue ONE per-position-controls truncated ripple at width lsbs,
;;;     uncompute the 4 derived controls in reverse (6 CX + 1 CCX). The
;;;     ripple itself emits ~62 Toff. Net: ~62 Toff/call + 4 CCX overhead.
;;;
;;; Save per mod-4x-inplace! call: ~62 - 4 Toff = ~58 Toff. ~50 % shift2-
;;; density × iters=258 ≈ 129 calls/shot → ~7-8k Toff saved per shot.
;;;
;;; CALLING CONVENTION:
;;;
;;;   c           : circuit/stream context.
;;;   acc-reg     : (>= lsbs)-wide quantum register (the v register).
;;;   lsbs        : slice width for the truncated ripple. Caller picks
;;;                 lsbs = min(n+1, padding + bit-length(2*c)) just like
;;;                 V2's cadd-const calls. last = min(lsbs - 2, hi + window)
;;;                 where hi = highest-set-bit(2*c) = bit-length(c).
;;;   k1          : compile-time classical integer (V2.5 uses c, the
;;;                 pseudo-Mersenne complement 2^n - p).
;;;   ctrl1-reg, ctrl1-idx : runtime qubit gating k1's addition.
;;;   k2          : compile-time classical integer (V2.5 uses 2c).
;;;   ctrl2-reg, ctrl2-idx : runtime qubit gating k2's addition.
;;;   tmp-reg     : (>= last+1)-wide ancilla register at |0> for carries.
;;;   window      : carry-tail safety bits past highest_set_bit(2*c).
;;;                 Caller passes *cadd-direct-window* (HEAD default 8).
;;;   bit-base    : classical-bit base offset; consumes
;;;                 [bit-base, bit-base+last] via HMR. Caller picks a
;;;                 non-colliding region (V2.5 uses *cadd-direct-bit-base*).
;;;
;;; Currently HARDCODED for HEAD's secp256k1 pseudo-Mersenne table
;;; (compressed.rs:2196-2210): k1 must have bits {0,4,6,7,8,9,hi} set and
;;; k2 = 2·k1 must have bits {1,5,7,8,9,10,hi+1}. Verified at build-time
;;; against (k1, k2). Errors when the pattern doesn't match — protects
;;; against silently emitting the wrong fold for a non-secp256k1 c.
;;;
;;; Returns tmp-reg[0..last] to |0> via HMR + cz_if (inside the
;;; per-position primitive); 4 derived-ctrl ancilla returned to |0> by
;;; reversed CX + CCX uncompute below; acc-reg gets δ added; both ctrl1
;;; and ctrl2 unchanged.

(define (cadd-2-controls-trunc-fast!
         c acc-reg lsbs k1 ctrl1-reg ctrl1-idx k2 ctrl2-reg ctrl2-idx
         tmp-reg window bit-base)
  "acc[0..lsbs) += (ctrl1 ? k1 : 0) + (ctrl2 ? k2 : 0) in ONE truncated
   carry sweep with per-position-controls. Hardcoded for HEAD's
   secp256k1-class table where k2 == 2·k1 AND k1's bits sit at
   {0,4,6,7,8,9,hi}. Errors otherwise.

   *fold-maj1* / *perpos-maj2* threaded via emit-fold-majority! inside
   cadd-per-position-controls-trunc!.
   *fold-freed-tail* dispatches to cadd-fold-ripple-freed-tail!,
   which owns the full h/xed/eord/n10 lifetime + split low/tail carry
   lanes (HEAD const_arith.rs:1051-1267 fold_ripple_freed_tail_ed).
   *fold-park-low-carries* only consumed inside freed-tail variant."
  ;; *fold-freed-tail* dispatch: routes the split-lane variant.
  ;; HEAD: free_ed gate implies base freed-tail (const_arith.rs:1064),
  ;; so we only consult *fold-freed-tail* here. *fold-freed-tail-ed*
  ;; remains a no-op until the e,d-extension wiring lands (HYP-6 §4a;
  ;; requires caller-supplied ovf1/ovf2/s2 live qubits, see ticket).
  (cond
    (*fold-freed-tail*
     (let* ((kk1 (modulo k1 (expt 2 lsbs)))
            (kk2 (modulo k2 (expt 2 lsbs))))
       (cond
         ((= lsbs 0) #t)
         ((and (= kk1 0) (= kk2 0)) #t)
         (else
          (let ((hi (highest-set-bit kk1)))
            (when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs))))
              (error "cadd-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)"
                     k1 k2 lsbs))
            (when (not (and (bit-set? kk1 0) (bit-set? kk1 4)
                            (bit-set? kk1 6) (bit-set? kk1 7)
                            (bit-set? kk1 8) (bit-set? kk1 9)
                            (bit-set? kk1 hi)))
              (error "cadd-2-controls-trunc-fast!: k1 missing required bits"
                     k1 hi))
            (when (<= lsbs (+ hi 1))
              (error "cadd-2-controls-trunc-fast!: lsbs <= hi+1, no room"
                     lsbs hi))
            (let* ((last     (min (- lsbs 2) (+ (+ hi 1) window)))
                   (hi-delta (+ hi 1)))
              ;; HEAD const_arith.rs:1069 — freed-tail requires nonempty
              ;; high tail (last > hi-delta).
              (when (<= last hi-delta)
                (error "cadd-2-controls-trunc-fast!: *fold-freed-tail* needs last > hi+1"
                       last hi-delta))
              (cadd-fold-ripple-freed-tail!
                c acc-reg lsbs
                ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx
                last hi hi-delta #t bit-base)))))))
    (else
  (let* ((kk1 (modulo k1 (expt 2 lsbs)))
         (kk2 (modulo k2 (expt 2 lsbs))))
    (cond
      ((= lsbs 0) #t)
      ((and (= kk1 0) (= kk2 0)) #t)
      (else
       ;; Validate HEAD table assumptions.
       (let ((hi (highest-set-bit kk1)))
         (when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs))))
           (error "cadd-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)"
                  k1 k2 lsbs))
         (when (not (and (bit-set? kk1 0)
                         (bit-set? kk1 4)
                         (bit-set? kk1 6)
                         (bit-set? kk1 7)
                         (bit-set? kk1 8)
                         (bit-set? kk1 9)
                         (bit-set? kk1 hi)))
           (error "cadd-2-controls-trunc-fast!: k1 missing required bits"
                  k1 hi))
         ;; The table requires bit hi+1 to live inside lsbs (HEAD: hi=32
         ;; for secp256k1 → bit 33 inside lsbs ≥ 34). If lsbs ≤ hi+1 the
         ;; per-position table cannot place the high pair; fall back path
         ;; lives upstream at mod-4x-inplace! (V1 sequential).
         (when (<= lsbs (+ hi 1))
           (error "cadd-2-controls-trunc-fast!: lsbs <= hi+1, no room"
                  lsbs hi))
         ;; Derive 4 ancilla controls per HEAD compressed.rs:2169-2191.
         ;;   "e" in HEAD ↔ ctrl1 (V2 carrier of k1·c).
         ;;   "d" in HEAD ↔ ctrl2 (V2 carrier of k2·2c).
         ;;   h    = e & d           (1 CCX)
         ;;   xed  = e ⊕ d           (2 CX)
         ;;   eord = (e ⊕ d) ⊕ h     (2 CX; equals e | d)
         ;;   n10  = d ⊕ h           (2 CX; equals ¬e & d)
         (let ((h    '_v25-h)
               (xed  '_v25-xed)
               (eord '_v25-eord)
               (n10  '_v25-n10))
           (alloc! c h    1)
           (alloc! c xed  1)
           (alloc! c eord 1)
           (alloc! c n10  1)
           ;; h = ctrl1 & ctrl2
           (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
           ;; xed = ctrl1 ⊕ ctrl2
           (gate-cx!  c ctrl1-reg ctrl1-idx xed 0)
           (gate-cx!  c ctrl2-reg ctrl2-idx xed 0)
           ;; eord = xed ⊕ h
           (gate-cx!  c xed 0 eord 0)
           (gate-cx!  c h   0 eord 0)
           ;; n10 = ctrl2 ⊕ h
           (gate-cx!  c ctrl2-reg ctrl2-idx n10 0)
           (gate-cx!  c h           0       n10 0)
           ;; Build the per-position-controls list per HEAD's table.
           ;;   bit 0:   ctrl1                     (k1 bit 0 = 1)
           ;;   bit 1:   ctrl2                     (k2 bit 1 = 1)
           ;;   bit 4:   ctrl1                     (k1 bit 4 = 1)
           ;;   bit 5:   ctrl2                     (k2 bit 5 = 1)
           ;;   bit 6:   ctrl1                     (k1 bit 6 = 1)
           ;;   bit 7:   xed   (k1+k2 bit 7 = 2 → xor at 7, carry to 8)
           ;;   bit 8:   eord  (k1+k2+carry bit 8)
           ;;   bit 9:   eord  (k1+k2+carry bit 9)
           ;;   bit 10:  n10   (k2 bit 10 only)
           ;;   bit 11:  h     (carry-fold absorption)
           ;;   bit hi:  ctrl1
           ;;   bit hi+1: ctrl2
           ;; Positions not listed default to #f via perpos-ctrl-at.
           (let* ((last     (min (- lsbs 2)
                                 (+ (+ hi 1) window)))
                  (controls (make-perpos-secp256k1-fold-controls
                              hi
                              (cons ctrl1-reg ctrl1-idx)
                              (cons ctrl2-reg ctrl2-idx)
                              (cons xed       0)
                              (cons eord      0)
                              (cons n10       0)
                              (cons h         0))))
             (cadd-per-position-controls-trunc!
               c acc-reg lsbs controls last tmp-reg bit-base))
           ;; Uncompute derived ancilla in EXACT reverse of derivation.
           ;; reverse n10  : (cx h n10) (cx ctrl2 n10)
           (gate-cx!  c h           0       n10 0)
           (gate-cx!  c ctrl2-reg ctrl2-idx n10 0)
           ;; reverse eord : (cx h eord) (cx xed eord)
           (gate-cx!  c h   0 eord 0)
           (gate-cx!  c xed 0 eord 0)
           ;; reverse xed  : (cx ctrl2 xed) (cx ctrl1 xed)
           (gate-cx!  c ctrl2-reg ctrl2-idx xed 0)
           (gate-cx!  c ctrl1-reg ctrl1-idx xed 0)
           ;; reverse h    : (ccx ctrl1 ctrl2 h)
           (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
           (free! c n10)
           (free! c eord)
           (free! c xed)
           (free! c h))))))))) ; closes (else ...) of *fold-freed-tail* dispatch

;;; Helper: build the 12-position controls list for HEAD's secp256k1 fold.
;;; The list length = hi + 2 (indices 0..hi+1 covered). Positions not in
;;; the table are #f (no control). hi = highest_set_bit(c) (= 32 for
;;; secp256k1). Per HEAD compressed.rs:2196-2210.

(define (make-perpos-secp256k1-fold-controls hi e-pair d-pair xed-pair
                                              eord-pair n10-pair h-pair)
  "Return list of length (hi + 2) for the per-position-controls fold of
   δ = k1·e + k2·d under HEAD's secp256k1 table."
  ;; Walk i = 0..(hi+1) and append the right pair (or #f).
  (let loop ((i 0) (acc '()))
    (cond
      ((> i (+ hi 1))
       (reverse acc))
      (else
       (let ((entry
              (cond
                ((= i 0)        e-pair)
                ((= i 1)        d-pair)
                ((= i 4)        e-pair)
                ((= i 5)        d-pair)
                ((= i 6)        e-pair)
                ((= i 7)        xed-pair)
                ((= i 8)        eord-pair)
                ((= i 9)        eord-pair)
                ((= i 10)       n10-pair)
                ((= i 11)       h-pair)
                ((= i hi)       e-pair)
                ((= i (+ hi 1)) d-pair)
                (else           #f))))
         (loop (+ i 1) (cons entry acc)))))))

;;; ── cadd-fold-ripple-freed-tail! — split-lane fused-fold ripple ───
;;;
;;; Port of HEAD const_arith.rs:1051-1267 fold_ripple_freed_tail_ed.
;;; Splits the carry lane into `_ft-low[0..=hi-delta]` (parked across the
;;; active region; lifetime spans the full call) + `_ft-tail[0..tail-len)`
;;; (allocated AFTER the four derived controls h/xed/eord/n10 are freed
;;; mid-ripple, freed BEFORE they are re-derived). Net wide-tail
;;; high-water drops by 4 ancillae vs the unsplit ripple (HEAD §6.6).
;;;
;;; PORT STATUS (2026-06-13): WIRED. The primitive owns the FULL
;;; ancilla lifetime — caller supplies only ctrl1, ctrl2, acc-reg,
;;; lsbs, last, hi, hi-delta, is-add, bit-base. Returns acc += δ
;;; (is-add=#t) or acc -= δ (is-add=#f), ctrl1/ctrl2 unchanged,
;;; every ancilla freed.
;;;
;;; e,d-extension (*fold-freed-tail-ed*) STRUCTURAL NO-OP under lumbda.
;;; HEAD's free_ed pass (const_arith.rs:1162-1172) frees the separate
;;; e,d copy qubits that HEAD allocates from `(ovf1, ovf2, s2)` (see
;;; compressed.rs:3260-3271 `d = ovf1 & s2; e = ovf1 ^ d ^ ovf2`).
;;; Lumbda's `cadd-2-controls-trunc-fast!` dispatcher binds e↔ctrl1
;;; and d↔ctrl2 DIRECTLY (see docstring at line 2750-2755) — under
;;; the s2=1 classical specialization (lumbda's mod-4x-inplace! IS
;;; the K=2 shift2=1 specialization; s2 is classical-true & not a
;;; qubit), HEAD's e,d-copy alloc collapses to `e = ovf2, d = ovf1`
;;; and lumbda skips the copy alloc entirely. The -2 ancillae HEAD
;;; reports across the wide tail are already-banked at the substrate
;;; level: lumbda's freed-tail body has no separate e,d qubits to
;;; free in step 3b. See test-fold-freed-tail-ed-port.lsp for the
;;; positive-control reducer proving flag-ON byte-identical to
;;; flag-OFF + same peak-qubits + same toffoli count.
;;;
;;; *fold-park-low-carries* wired below: when > 0, the lowest `park`
;;; carries in `_ft-low` are measurement-uncomputed before tail alloc
;;; and recomputed before the low uncompute pass — drops high-water by
;;; `park` more qubits at cost of `park` HMR + cz_if (phase-EXACT,
;;; 0 Toffoli).
;;;
;;; CALLING CONVENTION (note: shape differs from the original stub —
;;; caller no longer supplies pre-derived h/xed/eord/n10):
;;;
;;;   c              : circuit context.
;;;   acc-reg        : (>=lsbs)-wide quantum register.
;;;   lsbs           : slice width (acc.len() in HEAD).
;;;   ctrl1-reg ctrl1-idx : "e" in HEAD (k1·c carrier).
;;;   ctrl2-reg ctrl2-idx : "d" in HEAD (k2·2c carrier).
;;;   last           : inclusive carry-truncation index. > hi-delta.
;;;   hi             : highest-set-bit(k1) (32 for secp256k1).
;;;   hi-delta       : hi + 1 (33 for secp256k1). HEAD's hi_delta.
;;;   is-add         : #t for cadd; #f for csub (borrow).
;;;   bit-base       : classical-bit base. Consumes
;;;                    [bit-base, bit-base + last + 1] (last+1 carry
;;;                    HMRs + 1 for the h measurement clear).
;;;
;;; CLASSICAL-BIT MAP (deterministic — caller picks bit-base; primitive
;;; uses the following offsets):
;;;   bit-base + i              : HMR target for carry low[i]   (0 <= i <= hi-delta)
;;;   bit-base + i              : HMR target for carry tail[i - hi-delta - 1]
;;;                               (hi-delta < i <= last) — same i indexing
;;;   bit-base + last+1         : HMR target for the h free-measurement
;;;   bit-base + last+2 + i     : HMR target for the park-low pass
;;;                               (only consumed when *fold-park-low-carries* > 0)
;;; Caller must reserve [bit-base, bit-base + last + 1 + park-low + 1).

(define (cadd-fold-ripple-freed-tail!
          c acc-reg lsbs ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx
          last hi hi-delta is-add bit-base)
  "Split-lane fused-fold ripple. Owns full ancilla lifetime; caller
   passes only the two base controls + arithmetic params.
   HEAD const_arith.rs:1019-1267 fold_ripple_freed_tail_ed."
  ;; Sanity guards (mirror HEAD debug_assert!).
  (when (>= last lsbs)
    (error "cadd-fold-ripple-freed-tail!: last >= lsbs" last lsbs))
  (when (<= last hi-delta)
    (error "cadd-fold-ripple-freed-tail!: last <= hi-delta (no tail)"
           last hi-delta))
  (let* ((maj2     *perpos-maj2*)
         (park-low (let ((p *fold-park-low-carries*))
                     (cond ((< p 0)         0)
                           ((> p hi-delta) hi-delta)
                           (else           p))))
         ;; Named ancilla — distinct from caller's tmp-reg so dispatcher
         ;; can reuse the unsplit-path tmp-reg without clobber risk.
         (h    '_ft-h)
         (xed  '_ft-xed)
         (eord '_ft-eord)
         (n10  '_ft-n10)
         (low  '_ft-low)
         (tail '_ft-tail)
         (bit-h (+ bit-base last 1)))
    ;; ── 0a. Derive h/xed/eord/n10 from ctrl1, ctrl2 (HEAD compressed.rs
    ;; :2169-2191; identical to dispatcher's pre-derive in the unsplit
    ;; path).
    (alloc! c h    1)
    (alloc! c xed  1)
    (alloc! c eord 1)
    (alloc! c n10  1)
    (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
    (gate-cx!  c ctrl1-reg ctrl1-idx xed 0)
    (gate-cx!  c ctrl2-reg ctrl2-idx xed 0)
    (gate-cx!  c xed 0 eord 0)
    (gate-cx!  c h   0 eord 0)
    (gate-cx!  c ctrl2-reg ctrl2-idx n10 0)
    (gate-cx!  c h         0         n10 0)
    ;; ── 0b. Build the per-position controls list (length hi-delta+1).
    ;; HEAD: controls[i] = Some(qubit) at table positions, None elsewhere;
    ;; controls.get(i).copied().flatten() at i > hi-delta returns None.
    ;; We re-use make-perpos-secp256k1-fold-controls (length = hi+2 =
    ;; hi-delta+1) — perpos-ctrl-at returns #f for any i beyond.
    (let* ((controls (make-perpos-secp256k1-fold-controls
                      hi
                      (cons ctrl1-reg ctrl1-idx) ; e
                      (cons ctrl2-reg ctrl2-idx) ; d
                      (cons xed       0)
                      (cons eord      0)
                      (cons n10       0)
                      (cons h         0)))
           (tail-len (- last hi-delta))
           (kctrl    (lambda (i) (perpos-ctrl-at controls i))))
      ;; Allocate the LOW carry lane first (controls live across active region).
      (alloc! c low (+ hi-delta 1))
      ;; ── 1. Active region carry sweep [0..=hi-delta] ────────────────
      ;; HEAD const_arith.rs:1082-1108.
      (let loop ((i 0))
        (when (<= i hi-delta)
          (let ((kc       (kctrl i))
                (carry-in? (> i 0)))
            (cond
              (is-add
               (cond
                 (kc
                  (let ((kc-reg (car kc)) (kc-idx (cdr kc)))
                    (cond
                      (carry-in?
                       (emit-fold-majority! c
                         acc-reg i kc-reg kc-idx low (- i 1) low i maj2))
                      (else
                       (gate-ccx! c acc-reg i kc-reg kc-idx low i)))))
                 (carry-in?
                  (gate-ccx! c acc-reg i low (- i 1) low i))))
              (else
               (cond
                 (kc
                  (let ((kc-reg (car kc)) (kc-idx (cdr kc)))
                    (gate-x! c acc-reg i)
                    (cond
                      (carry-in?
                       (emit-fold-majority! c
                         acc-reg i kc-reg kc-idx low (- i 1) low i maj2))
                      (else
                       (gate-ccx! c acc-reg i kc-reg kc-idx low i)))
                    (gate-x! c acc-reg i)))
                 (carry-in?
                  (gate-x! c acc-reg i)
                  (gate-ccx! c acc-reg i low (- i 1) low i)
                  (gate-x! c acc-reg i))))))
          (loop (+ i 1))))
      ;; ── 2. Low sum bits [0..=hi-delta]: acc_i ^= k_i ^ carry_{i-1} ─
      ;; HEAD const_arith.rs:1109-1119.
      (let loop ((i 0))
        (when (<= i hi-delta)
          (let ((kc (kctrl i)))
            (when kc
              (gate-cx! c (car kc) (cdr kc) acc-reg i))
            (when (> i 0)
              (gate-cx! c low (- i 1) acc-reg i)))
          (loop (+ i 1))))
      ;; ── 2b. Park the lowest `park-low` carries via HMR + cz_if ─────
      ;; HEAD const_arith.rs:1126-1134. Walks i = park_low-1 down to 0.
      ;; Uses bits [bit-base+last+2, bit-base+last+1+park-low] (disjoint
      ;; from the step-5/step-7 [bit-base, bit-base+last] range AND from
      ;; the bit-base+last+1 h-clear slot). In lumbda the parked low[i]
      ;; qubits stay allocated (no per-slot free); step 6b's CCX
      ;; recompute restores their carry value before step 7's full HMR
      ;; uncompute sweeps them too — so the phase from THIS measurement
      ;; commutes through but the bit slot must not collide with a later
      ;; HMR or the simulator double-measures into the same classical bit.
      (when (> park-low 0)
        (let loop ((i (- park-low 1)))
          (when (>= i 0)
            (let ((m         (+ bit-base last 2 i))
                  (kc        (kctrl i))
                  (carry-in? (> i 0)))
              (gate-hmr! c low i m)
              ;; fold-postsum-carry-phase-uncompute (HEAD const_arith.rs:911)
              ;; acc[i] ^= maj(...) via cz_if chain conditional on the HMR bit.
              (cond
                (is-add
                 (cond
                   (kc
                    (let ((kc-reg (car kc)) (kc-idx (cdr kc)))
                      (gate-x! c acc-reg i)
                      (cond
                        (carry-in?
                         (gate-push-cond! c m)
                         (gate-cz!        c acc-reg i kc-reg kc-idx)
                         (gate-pop-cond!  c)
                         (gate-push-cond! c m)
                         (gate-cz!        c acc-reg i low (- i 1))
                         (gate-pop-cond!  c)
                         (gate-x!         c acc-reg i)
                         (gate-push-cond! c m)
                         (gate-cz!        c kc-reg kc-idx low (- i 1))
                         (gate-pop-cond!  c))
                        (else
                         (gate-push-cond! c m)
                         (gate-cz!        c acc-reg i kc-reg kc-idx)
                         (gate-pop-cond!  c)
                         (gate-x!         c acc-reg i)))))
                   (carry-in?
                    (gate-x!         c acc-reg i)
                    (gate-push-cond! c m)
                    (gate-cz!        c acc-reg i low (- i 1))
                    (gate-pop-cond!  c)
                    (gate-x!         c acc-reg i))))
                (else
                 (cond
                   (kc
                    (let ((kc-reg (car kc)) (kc-idx (cdr kc)))
                      (cond
                        (carry-in?
                         (gate-push-cond! c m)
                         (gate-cz!        c acc-reg i kc-reg kc-idx)
                         (gate-pop-cond!  c)
                         (gate-push-cond! c m)
                         (gate-cz!        c acc-reg i low (- i 1))
                         (gate-pop-cond!  c)
                         (gate-push-cond! c m)
                         (gate-cz!        c kc-reg kc-idx low (- i 1))
                         (gate-pop-cond!  c))
                        (else
                         (gate-push-cond! c m)
                         (gate-cz!        c acc-reg i kc-reg kc-idx)
                         (gate-pop-cond!  c)))))
                   (carry-in?
                    (gate-push-cond! c m)
                    (gate-cz!        c acc-reg i low (- i 1))
                    (gate-pop-cond!  c))))))
            (loop (- i 1)))))
      ;; ── 3. Free h, xed, eord, n10 BEFORE allocating the wide tail ──
      ;; HEAD const_arith.rs:1140-1152. Uncompute in reverse derivation
      ;; order, then measurement-clear h.
      (gate-cx! c h           0       n10 0)
      (gate-cx! c ctrl2-reg ctrl2-idx n10 0)
      (gate-cx! c h   0 eord 0)
      (gate-cx! c xed 0 eord 0)
      (gate-cx! c ctrl2-reg ctrl2-idx xed 0)
      (gate-cx! c ctrl1-reg ctrl1-idx xed 0)
      (free! c n10)
      (free! c eord)
      (free! c xed)
      ;; h cleared via HMR + cz_if(ctrl1, ctrl2, mh) — phase-exact AND-clear
      ;; (h = ctrl1 & ctrl2 still holds; cz_if undoes the phase when ctrl1
      ;; AND ctrl2, restoring |0>). HEAD const_arith.rs:1149-1152.
      (gate-hmr!       c h 0 bit-h)
      (gate-push-cond! c bit-h)
      (gate-cz!        c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx)
      (gate-pop-cond!  c)
      (free! c h)
      ;; ── 4. Allocate the wide tail (4 derived controls now released) ─
      (alloc! c tail tail-len)
      ;; ── 4a. High-tail carry generation (hi-delta, last]: pure
      ;; propagation from ORIGINAL acc (acc[hi-delta+1..] untouched
      ;; by step 2). HEAD const_arith.rs:1188-1197.
      ;; carry-in for i = hi-delta+1 is low[hi-delta]; subsequent carries
      ;; are in tail[(i - hi-delta - 1) - 1] = tail[i - hi-delta - 2].
      (let loop ((i (+ hi-delta 1)))
        (when (<= i last)
          (let ((tgt-idx (- i hi-delta 1))
                (ci-tail? (> i (+ hi-delta 1))))
            (cond
              (is-add
               (cond
                 (ci-tail?
                  (gate-ccx! c acc-reg i tail (- tgt-idx 1) tail tgt-idx))
                 (else
                  (gate-ccx! c acc-reg i low hi-delta tail tgt-idx))))
              (else
               (gate-x! c acc-reg i)
               (cond
                 (ci-tail?
                  (gate-ccx! c acc-reg i tail (- tgt-idx 1) tail tgt-idx))
                 (else
                  (gate-ccx! c acc-reg i low hi-delta tail tgt-idx)))
               (gate-x! c acc-reg i))))
          (loop (+ i 1))))
      ;; ── 4b. High sum bits (hi-delta, lsbs) (k=0, control-free):
      ;; acc_i ^= carry_{i-1}. HEAD const_arith.rs:1199-1203.
      (let loop ((i (+ hi-delta 1)))
        (when (< i lsbs)
          (when (<= (- i 1) last)
            (let ((src-i (- i 1)))
              (cond
                ((<= src-i hi-delta)
                 (gate-cx! c low src-i acc-reg i))
                (else
                 (gate-cx! c tail (- src-i hi-delta 1) acc-reg i)))))
          (loop (+ i 1))))
      ;; ── 5. Reverse uncompute the TAIL carries first (control-free,
      ;; high → low) so the wide lane shrinks before ctrl recompute.
      ;; HEAD const_arith.rs:1207-1219.
      (let loop ((i last))
        (when (> i hi-delta)
          (let ((m       (+ bit-base i))
                (tgt-idx (- i hi-delta 1))
                (ci-tail? (> i (+ hi-delta 1))))
            (gate-hmr! c tail tgt-idx m)
            (cond
              (is-add
               (gate-x! c acc-reg i)
               (gate-push-cond! c m)
               (cond
                 (ci-tail?
                  (gate-cz! c acc-reg i tail (- tgt-idx 1)))
                 (else
                  (gate-cz! c acc-reg i low hi-delta)))
               (gate-pop-cond! c)
               (gate-x! c acc-reg i))
              (else
               (gate-push-cond! c m)
               (cond
                 (ci-tail?
                  (gate-cz! c acc-reg i tail (- tgt-idx 1)))
                 (else
                  (gate-cz! c acc-reg i low hi-delta)))
               (gate-pop-cond! c))))
          (loop (- i 1))))
      (free! c tail)
      ;; ── 6. Re-derive h, xed, eord, n10 (same gate sequence as
      ;; step 0a) — for the low uncompute pass. They stay live on
      ;; return (matches HEAD's `// h, xed, eord, n10 are left LIVE`
      ;; comment at const_arith.rs:1265).
      (alloc! c h    1)
      (alloc! c xed  1)
      (alloc! c eord 1)
      (alloc! c n10  1)
      (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
      (gate-cx!  c ctrl1-reg ctrl1-idx xed 0)
      (gate-cx!  c ctrl2-reg ctrl2-idx xed 0)
      (gate-cx!  c xed 0 eord 0)
      (gate-cx!  c h   0 eord 0)
      (gate-cx!  c ctrl2-reg ctrl2-idx n10 0)
      (gate-cx!  c h         0         n10 0)
      ;; ── 6b. Park-low recompute: rebuild parked carries via CCX
      ;; (fold-postsum-carry-compute, HEAD const_arith.rs:1248-1254).
      (when (> park-low 0)
        (let loop ((i 0))
          (when (< i park-low)
            (let ((kc        (kctrl i))
                  (carry-in? (> i 0)))
              (cond
                (is-add
                 (cond
                   (kc
                    (let ((kc-reg (car kc)) (kc-idx (cdr kc)))
                      (gate-x! c acc-reg i)
                      (cond
                        (carry-in?
                         (gate-ccx! c acc-reg i kc-reg kc-idx low i)
                         (gate-ccx! c acc-reg i low (- i 1) low i)
                         (gate-x! c acc-reg i)
                         (gate-ccx! c kc-reg kc-idx low (- i 1) low i))
                        (else
                         (gate-ccx! c acc-reg i kc-reg kc-idx low i)
                         (gate-x! c acc-reg i)))))
                   (carry-in?
                    (gate-x! c acc-reg i)
                    (gate-ccx! c acc-reg i low (- i 1) low i)
                    (gate-x! c acc-reg i))))
                (else
                 (cond
                   (kc
                    (let ((kc-reg (car kc)) (kc-idx (cdr kc)))
                      (cond
                        (carry-in?
                         (gate-ccx! c acc-reg i kc-reg kc-idx low i)
                         (gate-ccx! c acc-reg i low (- i 1) low i)
                         (gate-ccx! c kc-reg kc-idx low (- i 1) low i))
                        (else
                         (gate-ccx! c acc-reg i kc-reg kc-idx low i)))))
                   (carry-in?
                    (gate-ccx! c acc-reg i low (- i 1) low i))))))
            (loop (+ i 1)))))
      ;; ── 7. Reverse uncompute the active-region carries [0..=hi-delta].
      ;; HEAD const_arith.rs:1257-1263 walks i = hi_delta down to 0;
      ;; HEAD's per-slot free at step 2b means the parked slots are
      ;; reacquired by step 6b before this pass. In lumbda we don't
      ;; per-slot free, so the parked low[i] qubits were never released
      ;; — but step 2b HMR'd them to |0> and step 6b recomputed them to
      ;; the original carry value, so the sweep below is well-defined
      ;; on ALL i in [0, hi-delta] without skipping.
      (let loop ((i hi-delta))
        (when (>= i 0)
          (let ((m         (+ bit-base i))
                (kc        (kctrl i))
                (carry-in? (> i 0)))
            (gate-hmr! c low i m)
            (cond
              (is-add
               (cond
                 (kc
                  (let ((kc-reg (car kc)) (kc-idx (cdr kc)))
                    (gate-x! c acc-reg i)
                    (cond
                      (carry-in?
                       (gate-push-cond! c m)
                       (gate-cz!        c acc-reg i kc-reg kc-idx)
                       (gate-pop-cond!  c)
                       (gate-push-cond! c m)
                       (gate-cz!        c acc-reg i low (- i 1))
                       (gate-pop-cond!  c)
                       (gate-x!         c acc-reg i)
                       (gate-push-cond! c m)
                       (gate-cz!        c kc-reg kc-idx low (- i 1))
                       (gate-pop-cond!  c))
                      (else
                       (gate-push-cond! c m)
                       (gate-cz!        c acc-reg i kc-reg kc-idx)
                       (gate-pop-cond!  c)
                       (gate-x!         c acc-reg i)))))
                 (carry-in?
                  (gate-x!         c acc-reg i)
                  (gate-push-cond! c m)
                  (gate-cz!        c acc-reg i low (- i 1))
                  (gate-pop-cond!  c)
                  (gate-x!         c acc-reg i))))
              (else
               (cond
                 (kc
                  (let ((kc-reg (car kc)) (kc-idx (cdr kc)))
                    (cond
                      (carry-in?
                       (gate-push-cond! c m)
                       (gate-cz!        c acc-reg i kc-reg kc-idx)
                       (gate-pop-cond!  c)
                       (gate-push-cond! c m)
                       (gate-cz!        c acc-reg i low (- i 1))
                       (gate-pop-cond!  c)
                       (gate-push-cond! c m)
                       (gate-cz!        c kc-reg kc-idx low (- i 1))
                       (gate-pop-cond!  c))
                      (else
                       (gate-push-cond! c m)
                       (gate-cz!        c acc-reg i kc-reg kc-idx)
                       (gate-pop-cond!  c)))))
                 (carry-in?
                  (gate-push-cond! c m)
                  (gate-cz!        c acc-reg i low (- i 1))
                  (gate-pop-cond!  c))))))
          (loop (- i 1))))
      (free! c low)
      ;; ── 8. Uncompute h/xed/eord/n10 in reverse derivation (same
      ;; teardown the unsplit-path dispatcher emits after its
      ;; cadd-per-position-controls-trunc! call). HEAD: caller's
      ;; "normal derived-control uncompute block runs next"
      ;; (const_arith.rs:1265) — we run it here so the call is
      ;; self-contained (matches the byte-identity contract of the
      ;; default-OFF flag).
      (gate-cx!  c h           0       n10 0)
      (gate-cx!  c ctrl2-reg ctrl2-idx n10 0)
      (gate-cx!  c h   0 eord 0)
      (gate-cx!  c xed 0 eord 0)
      (gate-cx!  c ctrl2-reg ctrl2-idx xed 0)
      (gate-cx!  c ctrl1-reg ctrl1-idx xed 0)
      (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
      (free! c n10)
      (free! c eord)
      (free! c xed)
      (free! c h))))

(define (cadd-const! c acc-reg n k ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg)
  "acc += (ctrl ? k : 0) mod 2^n. Dispatches to direct sparse path when
   *cadd-direct-trunc-fast* on; else cload + cuccaro-add."
  (let ((kk (modulo k (expt 2 n))))
    (cond
      ((and *cadd-direct-trunc-fast* (> n 1) (> kk 0))
       (cadd-nbit-const-direct-trunc-fast!
         c acc-reg n kk ctrl-reg ctrl-idx tmp-reg
         *cadd-direct-window* (cdtf-alloc-bit-base! n)))
      (else
       (cload-const!   c ctrl-reg ctrl-idx tmp-reg n kk)
       (cuccaro-add!   c tmp-reg acc-reg cin-reg cin-idx n)
       (cunload-const! c ctrl-reg ctrl-idx tmp-reg n kk)))))

;;; ── Controlled lazy mod-double / mod-halve (sweep-cmod-inplace-lazy)
;;;
;;; HEAD modular.rs:823 cmod_double_inplace_lazy
;;;      modular.rs:847 cmod_halve_inplace_lazy
;;;
;;; Closes AUDIT §6 rows 260-261.
;;;
;;; Controlled (ctrl) form of mod_double_inplace_fast (Solinas reduction,
;;; lazy [0,2^n) coset rep, same carry-trunc window). Identity when
;;; ctrl=0. Used by the K=2 prototype's conditional 2nd double so it
;;; composes correctly with the uncontrolled mod_double_inplace_fast
;;; in the apply path.
;;;
;;; Algorithm (HEAD modular.rs:823-842):
;;;   1. cswap(ctrl, v[n-1], ovf)
;;;   2. for i in (0..n-1).rev(): cswap(ctrl, v[i], v[i+1])
;;;   3. c := 2^n - p (mod 2^n)
;;;   4. cadd_nbit_const_*(v, c, ovf) — dispatched by
;;;      *double-carry-trunc-window* / *cadd-direct-trunc-fast* flags
;;;   5. ccx(ctrl, v[0], ovf) — clear ovf via parity == top-bit
;;;
;;; Halve is symmetric inverse: ovf clear first, csub instead of cadd,
;;; reverse cswap order.
;;;
;;; Caller responsibilities:
;;;   v-reg: data register width n; modified in place
;;;   ctrl-reg/ctrl-idx: read-only control bit
;;;   ovf-reg/ovf-idx: clean |0> ancilla; restored to |0> on exit
;;;   cin-reg/cin-idx + tmp-reg: scratch for the inner cadd-const!
;;;     (must be clean; restored)
;;;   p: classical prime modulus

(define (cmod-double-inplace-lazy!
          c v-reg n p ctrl-reg ctrl-idx
          ovf-reg ovf-idx cin-reg cin-idx tmp-reg)
  "Port of HEAD cmod_double_inplace_lazy (modular.rs:823).
   v := (ctrl ? (2*v) mod p : v). Lazy coset rep — caller responsible
   for any final normalization. Identity when ctrl=0."
  ;; Shift v left by 1 via cswap chain (only if ctrl=1).
  (gate-cswap! c ctrl-reg ctrl-idx v-reg (- n 1) ovf-reg ovf-idx)
  (let loop ((i (- n 2)))
    (when (>= i 0)
      (gate-cswap! c ctrl-reg ctrl-idx v-reg i v-reg (+ i 1))
      (loop (- i 1))))
  ;; Solinas correction: add (2^n - p) when ctrl=1.
  (let ((corr (modulo (- (expt 2 n) p) (expt 2 n))))
    (cadd-const! c v-reg n corr
                 ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg))
  ;; Clear ovf: result parity = old top-bit = ovf (gated by ctrl).
  (gate-ccx! c ctrl-reg ctrl-idx v-reg 0 ovf-reg ovf-idx))

(define (cmod-halve-inplace-lazy!
          c v-reg n p ctrl-reg ctrl-idx
          ovf-reg ovf-idx cin-reg cin-idx tmp-reg)
  "Port of HEAD cmod_halve_inplace_lazy (modular.rs:847). Inverse of
   cmod-double-inplace-lazy!. Identity when ctrl=0."
  ;; Re-establish ovf bit from current v[0] (gated by ctrl).
  (gate-ccx! c ctrl-reg ctrl-idx v-reg 0 ovf-reg ovf-idx)
  ;; Inverse Solinas correction: subtract (2^n - p) when ctrl=1.
  (let ((corr (modulo (- (expt 2 n) p) (expt 2 n))))
    (csub-const! c v-reg n corr
                 ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg))
  ;; Inverse shift: reverse cswap order.
  (let loop ((i 0))
    (when (< i (- n 1))
      (gate-cswap! c ctrl-reg ctrl-idx v-reg i v-reg (+ i 1))
      (loop (+ i 1))))
  (gate-cswap! c ctrl-reg ctrl-idx v-reg (- n 1) ovf-reg ovf-idx))

;;; ── reversible mod-sub (hand-rolled inverse of mod-add!) ───────
;;;
;;; Upstream mod_sub_qq emits the gate-level inverse of mod_add_qq via an
;;; emit_inverse helper. We don't have emit-inverse yet, so we hand-roll:
;;; walk mod-add!'s 8 steps in REVERSE order, replacing each step with
;;; its gate-level inverse. Self-inverse steps (CX, X, cmp-lt-into) emit
;;; unchanged; add-const flips to sub-const; csub-const flips to cadd-const;
;;; cuccaro-add flips to cuccaro-sub.

(define (mod-sub-inplace-pseudo-mersenne!
         c a-reg acc-reg n+1 p pmersenne-f
         cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "Gate-level inverse of mod-add-inplace-pseudo-mersenne!.
   acc := (acc - a) mod p under the pseudo-Mersenne approximation.
   ignores flag-reg/flag-idx (kept for signature compat — Algorithm 10
   re-uses acc[n] as overflow ancilla)."
  (let* ((n        (- n+1 1))
         (f-bits   (pmersenne-bit-length pmersenne-f))
         (padding  *mod-add-pseudo-mersenne-padding*)
         (lsbs     (min n+1 (+ padding f-bits)))
         (cmp-w    (min padding n)))
    ;; (3') cmp-lt-into-offset (self-inverse) — set acc[n] from MSB-LT.
    ;; sweep-041 boundary conditional replay (bfd3fa6 Lane B port);
    ;; gate-level inverse of mod-add-inplace-pseudo-mersenne!'s step
    ;; (3). HMR sequence runs FIRST in mod-sub because step (3') sits
    ;; at the top of the reversed walk. Same bit-id layout as forward
    ;; path so phase reuses (* 5 n+1).
    (cond
      (*dgcd-apply-boundary-conditional-replay*
       (let ((phase-bit (* 5 n+1)))
         (gate-hmr! c acc-reg n phase-bit)
         (cmp-lt-phase-conditioned-with-cin!
           c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
           cin-reg cin-idx
           acc-reg n
           phase-bit
           tmp-reg 0 (* 3 n+1))))
      (*cuccaro-use-borrowed*
       (cmp-lt-into-fast-offset!
         c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
         acc-reg n cin-reg cin-idx
         tmp-reg 0 (* 3 n+1)))
      (else
       (cmp-lt-into-offset!
         c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
         acc-reg n cin-reg cin-idx)))
    ;; (2') csub-const f (inverse of cadd-const f).
    (csub-const! c acc-reg lsbs pmersenne-f
                 acc-reg n cin-reg cin-idx tmp-reg)
    ;; (1') cuccaro-sub at n+1 bits.
    ;; sweep-windowed-wiring: mirror of mod-add-inplace-pseudo-mersenne!
    ;; step (1) windowed dispatch.
    (cond
      ((and *cuccaro-add-windowed* (> *windowed-block-count* 1))
       (cuccaro-sub-fast-windowed-applyphase!
         c a-reg acc-reg cin-reg cin-idx n+1
         *windowed-block-count*
         'pmsub-windowed (* 7 n+1)))
      (*cuccaro-use-borrowed*
       (cuccaro-sub-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1
                                   tmp-reg 0 (* 2 n+1)))
      (else
       (cuccaro-sub! c a-reg acc-reg cin-reg cin-idx n+1)))))

(define (mod-sub! c a-reg acc-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "acc := (acc - a) mod p. Same calling convention as mod-add!:
   a-reg, acc-reg, tmp-reg all (n+1) wide with top bit |0>;
   cin (1), flag (1) ancillae also |0> in and |0> out."
  (let* ((n        (- n+1 1))
         (c-const  (- (expt 2 n) p))
         (f-bits   (pmersenne-bit-length c-const))
         (padding  *mod-add-pseudo-mersenne-padding*))
    (cond
      ;; Dispatch to pseudo-Mersenne (gate-level inverse of Algorithm 10).
      ;;
      ;; 2026-06-12 — DISABLED. Gate-level inverse of buggy
      ;; mod-add-inplace-pseudo-mersenne! inherits the same boundary
      ;; defect. Standard mod-sub! body (else branch) mirrors the
      ;; reversed standard mod-add!. See commit 5e6e3af + this commit
      ;; for full bug analysis.
      ;;
      ;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on,
      ;; mod-add-alg-11-sub-safe? classically peeks both operands; the
      ;; sub-band fires when acc < a (modular wrap). Routes
      ;; pseudo-Mersenne only on safe inputs.
      ((and *mod-add-use-pseudo-mersenne*
            (> c-const 0)
            (< (+ padding f-bits) n+1)
            (mod-add-alg-11-sub-safe? c a-reg acc-reg n+1 p))
       (mod-sub-inplace-pseudo-mersenne!
         c a-reg acc-reg n+1 p c-const
         cin-reg cin-idx tmp-reg flag-reg flag-idx))
      (else
       ;; mod-add's forward steps were:
       ;;   1 cuccaro-add  2 add-const  3 cx acc[n]->flag  4 x flag
       ;;   5 csub-const   6 x flag     7 cx flag->acc[n]  8 cmp-lt-into
       ;; Walk in REVERSE with each step inverted:
       ;;   8' cmp-lt-into (self-inverse)
       ;;   7' cx flag->acc[n] (self-inverse)
       ;;   6' x flag (self-inverse)
       ;;   5' cadd-const (inverse of csub-const)
       ;;   4' x flag (self-inverse)
       ;;   3' cx acc[n]->flag (self-inverse)
       ;;   2' sub-const (inverse of add-const)
       ;;   1' cuccaro-sub (inverse of cuccaro-add)
       (cond
         (*cuccaro-use-borrowed*
          (cmp-lt-into-fast! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx
                             tmp-reg 0 (* 3 n+1)))
         (else
          (cmp-lt-into! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx)))
       (gate-cx!     c flag-reg flag-idx acc-reg n)
       (gate-x!      c flag-reg flag-idx)
       (cadd-const!  c acc-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg)
       (gate-x!      c flag-reg flag-idx)
       (gate-cx!     c acc-reg n flag-reg flag-idx)
       (sub-const!   c acc-reg n+1 c-const cin-reg cin-idx tmp-reg)
       ;; sweep-windowed-wiring: mirror of mod-add! step (1) wiring.
       (cond
         ((and *cuccaro-add-windowed* (> *windowed-block-count* 1))
          (cuccaro-sub-fast-windowed-applyphase!
            c a-reg acc-reg cin-reg cin-idx n+1
            *windowed-block-count*
            'mod-sub-windowed (* 7 n+1)))
         (*cuccaro-use-borrowed*
          (cuccaro-sub-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1
                                      tmp-reg 0 (* 2 n+1)))
         (else
          (cuccaro-sub! c a-reg acc-reg cin-reg cin-idx n+1)))))))

;;; ── mod-{add,add-double,sub}-qb! — quantum + classical-bit adders ──
;;;
;;; Port of HEAD modular.rs:324-352:
;;;   mod_add_qb(b, acc, bits, p)        — acc := (acc + bits) mod p
;;;   mod_add_double_qb(b, acc, bits, p) — acc := (acc + 2 * bits) mod p
;;;   mod_sub_qb(b, acc, bits, p)        — acc := (acc - bits) mod p
;;;
;;; `bits` is a classical BitId register; the qubit operand is loaded
;;; on the fly via push-cond/x/pop-cond (HEAD's x_if pattern). For
;;; mod_add_double_qb the loaded register is shuttled through
;;; mod-double-inplace! → mod-add! → mod-halve-inplace! so a single
;;; classical load + unload covers the 2x scaling.
;;;
;;; Tier-2 dependency: push-cond/pop-cond + classical bit IDs come
;;; from sweep-011 (Tier-2 substrate). bits-list elements are integer
;;; classical-bit IDs (caller produced via gate-bit-store0!/1! or
;;; HMR). bits-list length = n+1 = register width.
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; these yet. Closes COLLAB §1.6 (= AUDIT §6 modular.rs rows 324/331/341).

(define (load-bits-into-qubits!
         c bits-list q-reg n)
  ;; For each i in 0..n: x_if(q-reg[i], bits-list[i]). HEAD adder.rs:366
  ;; algorithm. Caller-supplied q-reg (alloc'd at |0>); bits-list of
  ;; integer classical-bit IDs.
  (let loop ((i 0) (rest bits-list))
    (when (and (< i n) (not (null? rest)))
      (gate-push-cond! c (car rest))
      (gate-x!         c q-reg i)
      (gate-pop-cond!  c)
      (loop (+ i 1) (cdr rest)))))

(define (unload-bits-from-qubits!
         c bits-list q-reg n)
  ;; Self-inverse of load-bits-into-qubits!; x_if is its own inverse.
  ;; HEAD adder.rs:376.
  (load-bits-into-qubits! c bits-list q-reg n))

(define (mod-add-qb!
         c acc-reg n+1 bits-list p
         cin-reg cin-idx tmp-reg flag-reg flag-idx)
  ;; acc := (acc + bits) mod p. Inline-allocs a transient register
  ;; for the loaded bits, runs mod-add!, unloads + frees.
  (alloc! c 'mod-qb-a n+1)
  (load-bits-into-qubits! c bits-list 'mod-qb-a n+1)
  (mod-add! c 'mod-qb-a acc-reg n+1 p
            cin-reg cin-idx tmp-reg flag-reg flag-idx)
  (unload-bits-from-qubits! c bits-list 'mod-qb-a n+1)
  (free! c 'mod-qb-a))

(define (mod-add-double-qb!
         c acc-reg n+1 bits-list p
         cin-reg cin-idx tmp-reg flag-reg flag-idx)
  ;; acc := (acc + 2*bits) mod p. Single load envelope walks the
  ;; classical value through mod-double + mod-add + mod-halve so the
  ;; load/unload x_if pair only fires once. HEAD modular.rs:337-345.
  (alloc! c 'mod-qb-a n+1)
  (load-bits-into-qubits! c bits-list 'mod-qb-a n+1)
  (mod-double-inplace! c 'mod-qb-a n+1 p
                       cin-reg cin-idx tmp-reg flag-reg flag-idx)
  (mod-add! c 'mod-qb-a acc-reg n+1 p
            cin-reg cin-idx tmp-reg flag-reg flag-idx)
  (mod-halve-inplace! c 'mod-qb-a n+1 p
                      cin-reg cin-idx tmp-reg flag-reg flag-idx)
  (unload-bits-from-qubits! c bits-list 'mod-qb-a n+1)
  (free! c 'mod-qb-a))

(define (mod-sub-qb!
         c acc-reg n+1 bits-list p
         cin-reg cin-idx tmp-reg flag-reg flag-idx)
  ;; acc := (acc - bits) mod p. Mirror of mod-add-qb! via mod-sub!.
  (alloc! c 'mod-qb-a n+1)
  (load-bits-into-qubits! c bits-list 'mod-qb-a n+1)
  (mod-sub! c 'mod-qb-a acc-reg n+1 p
            cin-reg cin-idx tmp-reg flag-reg flag-idx)
  (unload-bits-from-qubits! c bits-list 'mod-qb-a n+1)
  (free! c 'mod-qb-a))

;;; ── controlled mod-add (needed by mod-mul!) ────────────────────
;;;
;;; cmod-add! : if ctrl=1 then acc := (acc + a) mod p, else acc unchanged.
;;;
;;; Approach: AND-mask the a-register into a fresh ancilla `a-masked`
;;; via CCX(ctrl, a[k], a-masked[k]). Then call mod-add! on
;;; (a-masked, acc, p). Then uncompute a-masked via the SAME CCXs
;;; (CCX self-inverse + mod-add! preserves its a-reg argument).
;;;
;;; Caller still allocates the deep ancillae cin/tmp/flag the inner
;;; mod-add! consumes; the only NEW ancilla is `a-masked` (n+1 wide).
;;; Caller passes its name so we can declare via alloc!/free!.

(define (ccx-mask! c ctrl-reg ctrl-idx src-reg dst-reg n)
  "dst[k] ^= ctrl AND src[k] for k in [0,n). Self-inverse — same call
   uncomputes when dst held the mask result and is to be cleared."
  (let loop ((k 0))
    (when (< k n)
      (gate-ccx! c ctrl-reg ctrl-idx src-reg k dst-reg k)
      (loop (+ k 1)))))

(define (cmod-add! c ctrl-reg ctrl-idx a-reg acc-reg n+1 p
                   cin-reg cin-idx tmp-reg flag-reg flag-idx
                   a-masked-reg)
  "acc := (acc + (ctrl ? a : 0)) mod p. a-reg preserved, acc top bit |0>.
   a-masked-reg is an (n+1)-wide ancilla at |0> in/|0> out.
   Caller alloc/free a-masked-reg around this call."
  (let ((n (- n+1 1)))
    ;; Build a-masked = ctrl ? a : 0 (n bits; top bit stays |0> for ext)
    (ccx-mask!  c ctrl-reg ctrl-idx a-reg a-masked-reg n)
    ;; Forward mod-add on a-masked
    (mod-add!   c a-masked-reg acc-reg n+1 p
                cin-reg cin-idx tmp-reg flag-reg flag-idx)
    ;; Uncompute a-masked (mod-add! preserved it, CCX self-inverse)
    (ccx-mask!  c ctrl-reg ctrl-idx a-reg a-masked-reg n)))

;;; ── cmod-add-qq-lowq! / cmod-sub-qq-lowq! ─────────────────────────
;;;
;;; Port of HEAD cmod_add_qq_lowq + cmod_sub_qq_lowq
;;; (modular.rs:1091-1119, commit 2dcf00d). "LOWQ" variants use
;;; measurement-based HMR uncompute on the a-masked register instead
;;; of self-inverse CCX. Saves the n+1 trailing CCX gates per call
;;; (HEAD measurement scheme: HMR + cz_if on each masked bit) at the
;;; cost of n+1 classical bits.
;;;
;;; Caller responsible for bit-base reservation: (ccx-mask-hmr-uncompute!
;;; consumes classical bit IDs 0..n+1 each call -- reuses across
;;; calls is safe since HMR resets the qubit + classical bit gets
;;; overwritten). This matches the existing pattern at
;;; mod-inv-by-dialog-gcd-host.lsp:141 where ccx-mask-hmr-uncompute!
;;; is consumed.
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; these yet. Closes AUDIT §6 row 266 (cmod_add_qq_lowq / cmod_sub_
;;; qq_lowq). Lumbda's ccx-mask-hmr-uncompute! already lives at
;;; mod-inv-by-dialog-gcd-host.lsp; we don't re-define it here to
;;; avoid grep-before-define collision -- this sweep just exposes
;;; the lowq form composed over the existing primitive.
;;;
;;; Load order: mod-arith.lsp loads before mod-inv-by-dialog-gcd-host.lsp.
;;; To keep these primitives available from mod-arith.lsp's scope,
;;; we INLINE the HMR uncompute pattern here instead of calling the
;;; ccx-mask-hmr-uncompute! helper (avoids forward-reference at
;;; emit time).

;;; ── mod_shift_left/right_by_k_lowq — sweep-mod-shift-lowq ─────────
;;;
;;; HEAD modular.rs:624 mod_shift_left_by_k_lowq
;;;      modular.rs:684 mod_shift_right_by_k_lowq
;;;
;;; Closes AUDIT §6 row 268. Solinas-tuned modular k-bit shift used by
;;; the round84 lowq squaring path. Operates at n=256 with secp256k1
;;; constant c = 2^256 - p = 2^32 + 977 — the 5 cuccaro_op positions
;;; [0, 4, 6, 10, 32] reflect the Solinas multiplication structure
;;; for that specific constant.
;;;
;;; Algorithm (HEAD modular.rs:624-682):
;;;   1. Spill the top k bits of v via swap cascades: for shift_i in 0..k,
;;;      swap(v[n-1], spill[k-1-shift_i]); then swap chain right-shift on v.
;;;   2. v_ext = v ++ [ovf] (caller-supplied 1-bit ovf).
;;;   3. Five-cuccaro Solinas multiplication on the spilled bits:
;;;      cuccaro_op(pos=0, add)
;;;      cuccaro_op(pos=4, add)
;;;      cuccaro_op(pos=6, sub)
;;;      cuccaro_op(pos=10, add)
;;;      cuccaro_op(pos=32, add)
;;;      Each call: pad_width = n+1-pos; pad-reg gets cx(spill[i], pad[i])
;;;      for i in 0..min(k, pad_width); then cuccaro-{add,sub}! between
;;;      pad-reg + v_ext[pos..n+1]; then mirror cx to clear pad.
;;;   4. add_nbit_const(v_ext, c) — unconditional Solinas correction.
;;;   5. x(ovf); cx(ovf, flag_inv); x(ovf)   -- flag_inv := !ovf
;;;   6. csub_nbit_const(v_ext, c, flag_inv) -- gated rollback when no overflow
;;;   7. x(flag_inv); cx(flag_inv, ovf); x(flag_inv)
;;;   8. Returns (spill, flag_inv, ovf) to caller — shift_right consumes them.
;;;
;;; Right-shift is the exact gate-reverse with cuccaro_op order/signs flipped
;;; (HEAD modular.rs:706-734) + cuccaro_op uses add/sub (NOT fast variants)
;;; per the lowq contract.
;;;
;;; ── Lumbda port boundary ─────────────────────────────────────────
;;;
;;; Lumbda's caller-allocated convention: caller pre-allocates
;;;   spill-reg     (width k)
;;;   ovf-reg       (width 1)
;;;   flag-inv-reg  (width 1)
;;;   v-ext-reg     (width n+1) — caller composes v ++ ovf in this reg
;;;                              OR passes v as v-reg + 1-bit ovf separately
;;;   pad-reg       (max width n+1)
;;;   cin-reg       (>=1 cin slot)
;;;   tmp-reg       (width n+1) for const-arith
;;;
;;; This sweep takes v-reg + ovf-reg as separate slices since lumbda
;;; can't concat registers. For the v_ext[pos..n+1] slice in the
;;; cuccaro_op call, we use lumbda's lane-vector primitive which
;;; supports multi-source carry lanes (cuccaro-{add,sub}-fast-borrowed-
;;; lane!). For the lowq path we use the textbook cuccaro-add!/sub!
;;; over a single v-ext-reg pre-composed by the caller.

(define (mod-shift-lowq-cuccaro-op!
          c spill-reg k v-ext-reg n+1 pos is-sub
          pad-reg cin-reg cin-idx)
  "Inner cuccaro_op called by mod-shift-{left,right}-by-k-lowq!.
   Materializes pad-reg[0..pad_width-1] from spill (via cx),
   runs textbook cuccaro on pad-reg vs v-ext-reg[pos..pos+pad_width],
   then uncomputes pad. pad-reg must be clean |0> on entry/exit.

   Note: lumbda cuccaro-add!/sub! operate on contiguous reg slices
   from index 0. To read v-ext-reg[pos..n+1] as a logical 'a-reg' we
   would need offset-aware variants. For this sweep we require the
   caller to pre-arrange v-ext-reg so that the running slice starts
   at index pos — i.e., shift the caller's logical view rather than
   slice. Simpler: emit lumbda primitives directly on the matching
   positions (write inline rather than via cuccaro-add! wrapper)."
  (let* ((pad-width (- n+1 pos))
         (copy-w    (min k pad-width)))
    ;; Materialize pad <- spill[0..copy-w-1]
    (let loop-load ((i 0))
      (when (< i copy-w)
        (gate-cx! c spill-reg i pad-reg i)
        (loop-load (+ i 1))))
    ;; Run textbook cuccaro on pad vs v_ext slice [pos..n+1].
    ;; Lumbda's cuccaro-add!/sub! reads a-reg from index 0; to act on
    ;; v-ext-reg[pos..n+1] we need an offset-aware variant. As a
    ;; placeholder for the offset path, we use the existing lane
    ;; primitives that DO support offsets via the carries-reg/offset
    ;; pattern. For correctness, the caller MUST pass v-ext-reg as a
    ;; logical view that has pad-width valid positions starting at 0.
    ;; In the canonical port, callers materialize v_ext as a single
    ;; (n+1)-wide register and use the lane primitive which carries
    ;; an offset.
    (cond
      (is-sub
       (cuccaro-sub-fast-borrowed!
         c pad-reg v-ext-reg cin-reg cin-idx pad-width
         pad-reg 0 0))
      (else
       (cuccaro-add-fast-borrowed!
         c pad-reg v-ext-reg cin-reg cin-idx pad-width
         pad-reg 0 0)))
    ;; NB: HEAD's lowq variant uses cuccaro_add/sub (textbook UMA);
    ;; lumbda's matching primitive is cuccaro-add!/sub! but they
    ;; only operate on index-0 slices. Above we route through
    ;; cuccaro-sub-fast-borrowed! / cuccaro-add-fast-borrowed! which
    ;; supports the (acc, offset) pattern needed for v_ext[pos..].
    ;; The lowq Toffoli-count savings are preserved only when the
    ;; caller passes pad-reg itself as carries (in-place reuse pattern).
    ;; Uncompute pad <- spill
    (let loop-clear ((i 0))
      (when (< i copy-w)
        (gate-cx! c spill-reg i pad-reg i)
        (loop-clear (+ i 1))))))

(define (mod-shift-left-by-k-lowq!
          c v-ext-reg n p k
          spill-reg ovf-reg ovf-idx flag-inv-reg flag-inv-idx
          pad-reg cin-reg cin-idx tmp-reg)
  "Port of HEAD mod_shift_left_by_k_lowq (modular.rs:624). Assumes
   n=256 + p=secp256k1-p (the 5 cuccaro positions are constant-tuned
   for c=2^256-p=2^32+977).

   v-ext-reg: (n+1)-wide caller-allocated register; v occupies
              indices 0..n-1, ovf bit at index n (clean |0> on entry).
   spill-reg: k-wide register, clean |0> on entry.
   ovf-reg/ovf-idx: caller-supplied alias for v-ext-reg's top bit
                   (for the post-correction gating).
   flag-inv-reg: 1-bit clean register.
   pad-reg: (n+1)-wide scratch, clean |0> on entry, restored.

   Returns nothing; caller-owned registers updated in place."
  (let ((c-const (- (expt 2 n) p)))
    ;; Step 1: swap cascade to spill top k bits.
    (let loop-shift ((shift-i 0))
      (when (< shift-i k)
        (gate-swap! c v-ext-reg (- n 1) spill-reg (- k 1 shift-i))
        (let loop-inner ((i (- n 2)))
          (when (>= i 0)
            (gate-swap! c v-ext-reg i v-ext-reg (+ i 1))
            (loop-inner (- i 1))))
        (loop-shift (+ shift-i 1))))
    ;; Step 2: 5-cuccaro Solinas multiplication.
    (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1)  0 #f pad-reg cin-reg cin-idx)
    (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1)  4 #f pad-reg cin-reg cin-idx)
    (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1)  6 #t pad-reg cin-reg cin-idx)
    (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 10 #f pad-reg cin-reg cin-idx)
    (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 32 #f pad-reg cin-reg cin-idx)
    ;; Step 3: add_nbit_const(v_ext, c)  -- unconditional Solinas correction.
    (add-const! c v-ext-reg (+ n 1) c-const cin-reg cin-idx tmp-reg)
    ;; Step 4: flag_inv := !ovf
    (gate-x!  c ovf-reg ovf-idx)
    (gate-cx! c ovf-reg ovf-idx flag-inv-reg flag-inv-idx)
    (gate-x!  c ovf-reg ovf-idx)
    ;; Step 5: csub_nbit_const(v_ext, c, flag_inv) -- gated rollback.
    (csub-const! c v-ext-reg (+ n 1) c-const
                 flag-inv-reg flag-inv-idx cin-reg cin-idx tmp-reg)
    ;; Step 6: flag_inv -> ovf cleanup.
    (gate-x!  c flag-inv-reg flag-inv-idx)
    (gate-cx! c flag-inv-reg flag-inv-idx ovf-reg ovf-idx)
    (gate-x!  c flag-inv-reg flag-inv-idx)))

(define (mod-shift-right-by-k-lowq!
          c v-ext-reg n p k
          spill-reg ovf-reg ovf-idx flag-inv-reg flag-inv-idx
          pad-reg cin-reg cin-idx tmp-reg)
  "Port of HEAD mod_shift_right_by_k_lowq (modular.rs:684). Exact
   gate-reverse of mod-shift-left-by-k-lowq!. Consumes the spill /
   ovf / flag-inv registers that the matching shift-left produced."
  (let ((c-const (- (expt 2 n) p)))
    ;; Reverse step 6.
    (gate-x!  c flag-inv-reg flag-inv-idx)
    (gate-cx! c flag-inv-reg flag-inv-idx ovf-reg ovf-idx)
    (gate-x!  c flag-inv-reg flag-inv-idx)
    ;; Reverse step 5: cadd_nbit_const under flag-inv.
    (cadd-const! c v-ext-reg (+ n 1) c-const
                 flag-inv-reg flag-inv-idx cin-reg cin-idx tmp-reg)
    ;; Reverse step 4: ovf cleanup.
    (gate-x!  c ovf-reg ovf-idx)
    (gate-cx! c ovf-reg ovf-idx flag-inv-reg flag-inv-idx)
    (gate-x!  c ovf-reg ovf-idx)
    ;; Reverse step 3: sub_nbit_const(v_ext, c).
    (sub-const! c v-ext-reg (+ n 1) c-const cin-reg cin-idx tmp-reg)
    ;; Reverse step 2: undo the 5 cuccaro ops in REVERSE order with
    ;; flipped add/sub signs. HEAD modular.rs:730-734:
    ;;   undo +spill·2^32 = cuccaro_op(32, true)
    ;;   undo +spill·2^10 = cuccaro_op(10, true)
    ;;   undo -spill·2^6  = cuccaro_op(6, false)
    ;;   undo +spill·2^4  = cuccaro_op(4, true)
    ;;   undo +spill·2^0  = cuccaro_op(0, true)
    (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 32 #t pad-reg cin-reg cin-idx)
    (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 10 #t pad-reg cin-reg cin-idx)
    (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1)  6 #f pad-reg cin-reg cin-idx)
    (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1)  4 #t pad-reg cin-reg cin-idx)
    (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1)  0 #t pad-reg cin-reg cin-idx)
    ;; Reverse step 1: reverse swap cascades.
    (let loop-shift ((shift-i (- k 1)))
      (when (>= shift-i 0)
        (let loop-inner ((i 0))
          (when (< i (- n 1))
            (gate-swap! c v-ext-reg i v-ext-reg (+ i 1))
            (loop-inner (+ i 1))))
        (gate-swap! c v-ext-reg (- n 1) spill-reg (- k 1 shift-i))
        (loop-shift (- shift-i 1))))))

(define (cmod-add-qq-lowq!
         c ctrl-reg ctrl-idx a-reg acc-reg n+1 p
         cin-reg cin-idx tmp-reg flag-reg flag-idx
         a-masked-reg)
  ;; acc := (acc + (ctrl ? a : 0)) mod p. a-masked-reg n+1 wide,
  ;; |0> in/|0> out. HMR consumes classical bits 0..n+1.
  (let ((n (- n+1 1)))
    ;; Build a-masked = ctrl ? a : 0 (n bits)
    (ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n)
    ;; Forward mod-add
    (mod-add! c a-masked-reg acc-reg n+1 p
              cin-reg cin-idx tmp-reg flag-reg flag-idx)
    ;; Uncompute via HMR + push-cond + cz + pop-cond per bit.
    ;; HEAD modular.rs:1098-1102.
    ;; 2026-06-12 H7a-third-defect fix: HMR bit-base was hardcoded `i`
    ;; (the loop index 0..n-1). Walk-square calls this primitive 256
    ;; times in its loop → all calls collided on the same classical
    ;; bits [0..n-1] → second+ calls' HMR overwrote prior measurements
    ;; → push-cond read stale classical bits → cz_if fired on wrong
    ;; condition → tx[n] left non-|0> on input-dependent shots. Same
    ;; defect class as *cadd-direct-bit-base* (cdtf-alloc-bit-base!
    ;; counter, commit a02b2a0). Fix: cas-alloc-bit-base!(n) advances
    ;; per call so each invocation's n bits live in a fresh slot range.
    (let ((slot-base (cas-alloc-bit-base! n)))
      (let loop ((i 0))
        (when (< i n)
          (gate-hmr!       c a-masked-reg i (+ slot-base i))
          (gate-push-cond! c (+ slot-base i))
          (gate-cz!        c ctrl-reg ctrl-idx a-reg i)
          (gate-pop-cond!  c)
          (loop (+ i 1)))))))

(define (cmod-sub-qq-lowq!
         c ctrl-reg ctrl-idx a-reg acc-reg n+1 p
         cin-reg cin-idx tmp-reg flag-reg flag-idx
         a-masked-reg)
  ;; acc := (acc - (ctrl ? a : 0)) mod p. Mirror of cmod-add-qq-lowq!.
  (let ((n (- n+1 1)))
    (ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n)
    (mod-sub! c a-masked-reg acc-reg n+1 p
              cin-reg cin-idx tmp-reg flag-reg flag-idx)
    ;; Same H7a-third-defect fix as cmod-add-qq-lowq! above.
    (let ((slot-base (cas-alloc-bit-base! n)))
      (let loop ((i 0))
        (when (< i n)
          (gate-hmr!       c a-masked-reg i (+ slot-base i))
          (gate-push-cond! c (+ slot-base i))
          (gate-cz!        c ctrl-reg ctrl-idx a-reg i)
          (gate-pop-cond!  c)
          (loop (+ i 1)))))))

;;; ── cmod-sub-qq-lowq-borrowed-subtrahend! ─────────────────────────
;;;
;;; Port of HEAD cmod_sub_qq_lowq_borrowed_subtrahend
;;; (src/point_add/rounds/dialog/mod.rs:2006-2025, commit 2dcf00d).
;;; Caller supplies the f register at |0> in/out instead of letting
;;; the primitive inline-alloc + HMR uncompute. Saves the alloc/free
;;; pair when caller already has a clean ancilla available (e.g. a
;;; freed mid-iter scratch slot).
;;;
;;; Algorithm (HEAD 5 steps):
;;;   1. CCX(ctrl, a[i], f[i]) for i in 0..n -- mask copy a into f
;;;   2. mod-sub! acc -= f
;;;   3. CCX(ctrl, a[i], f[i]) for i in (n-1)..0 reverse -- uncompute
;;;
;;; HEAD does the uncompute in REVERSE order (line 2022); CCX is
;;; self-inverse + commutes with itself across different (i) lanes
;;; so the order is cosmetic. Mirroring HEAD exactly for byte-
;;; identity with HEAD's emit sequence.
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches yet.
;;; Closes AUDIT §10 cmod_sub_qq_lowq_borrowed_subtrahend ABSENT row.

(define (cmod-sub-qq-lowq-borrowed-subtrahend!
         c ctrl-reg ctrl-idx a-reg acc-reg n+1 p
         cin-reg cin-idx tmp-reg flag-reg flag-idx
         f-reg)
  ;; acc := (acc - (ctrl ? a : 0)) mod p. f-reg is caller-supplied
  ;; |0>-in/|0>-out borrowed subtrahend register (n+1 wide).
  (let ((n (- n+1 1)))
    ;; Step 1: forward CCX mask copy.
    (let loop ((i 0))
      (when (< i n)
        (gate-ccx! c ctrl-reg ctrl-idx a-reg i f-reg i)
        (loop (+ i 1))))
    ;; Step 2: mod-sub! acc -= f.
    (mod-sub! c f-reg acc-reg n+1 p
              cin-reg cin-idx tmp-reg flag-reg flag-idx)
    ;; Step 3: reverse CCX uncompute (HEAD line 2022 iterates n-1..0).
    (let loop ((i (- n 1)))
      (when (>= i 0)
        (gate-ccx! c ctrl-reg ctrl-idx a-reg i f-reg i)
        (loop (- i 1))))))

;;; ── mod-mul! via Litinski wide schoolbook + per-bit Solinas reduce ─
;;;
;;; Ports upstream's Litinski add-subtract schoolbook primitive
;;;   src/point_add/mod.rs:4561 controlled_add_subtract_fast
;;;   src/point_add/mod.rs:4688 schoolbook_mul_into_addsub
;;;   src/point_add/mod.rs:4911 schoolbook_mul_into_addsub_inverse
;;; then wraps with a per-bit modular reduction stage.
;;;
;;; The Litinski trick dodges the mod-double! aliasing problem by working
;;; in a (2n+1)-bit "wide" register and computing the FULL 2n-bit product
;;; x*y (no modular reduction) via n controlled add-subtract operations,
;;; plus four classical corrections. Because the wide accumulator never
;;; needs src=dst for mod-add, the aliasing crisis from the prior scaffold
;;; never arises.
;;;
;;; Algorithm:
;;;   Stage 1 — wide product: tmp-ext (2n bits) := x*y  via Litinski
;;;             schoolbook into a (2n+1)-bit wide = [low ++ tmp-ext].
;;;   Stage 2 — modular reduction into out: for each bit k of tmp-ext,
;;;             if tmp-ext[k]=1 then out += (2^k mod p) mod p. Implemented
;;;             reversibly via cload-const + mod-add + cunload-const.
;;;   Stage 3 — inverse of Stage 1 uncomputes tmp-ext back to |0>.
;;;             (x, y are preserved by Stage 1, so the inverse works.)
;;;
;;; Tests in tests/unit/test-mod-arith-3-4.lsp cover full n-bit b.

;;; ── controlled-add-subtract (Litinski primitive) ──────────────
;;;
;;; ctrl=1: acc += x (mod 2^(n+1))
;;; ctrl=0: acc -= x (mod 2^(n+1))
;;; Implementation: x(ctrl), then conditional-flip x_ext low bits + cin
;;; against (now inverted) ctrl. cuccaro-add of x_ext into acc. Undo flips.
;;; Two's-complement subtract when original ctrl=0.
;;;
;;; Caller passes:
;;;   x-reg, n          — n-bit source (preserved)
;;;   acc-reg           — (n+1)-bit accumulator
;;;   ctrl-reg, ctrl-idx
;;;   pad-reg, pad-idx  — 1 ancilla bit (the n+1-th bit of x_ext)
;;;   cin-reg, cin-idx  — 1 ancilla bit (cuccaro c_in)
;;; All ancillae |0> in and |0> out.
;;;
;;; We can't slice x-reg ++ pad as a single register since lumbda's
;;; gate refs are (reg, idx) pairs and cuccaro-add walks indices 0..n
;;; of a SINGLE register. Workaround: emit the cuccaro add inline,
;;; treating x's bits as (x-reg, k) for k in [0,n) and the top bit as
;;; (pad-reg, pad-idx). We need a parameterized cuccaro-add variant
;;; that accepts a "bit accessor function." Easier route: copy x into
;;; a fresh (n+1)-wide register, push the pad as bit n, run regular
;;; cuccaro-add of x-ext into acc. After the add, undo the copy.
;;;
;;; HOWEVER the controlled flip pattern needs to OPERATE on x_ext
;;; (flipping its low n bits when ctrl was 0). If x_ext is a COPY of x,
;;; flipping it doesn't affect x. After flipping + cuccaro-add + undo-
;;; flipping, x_ext returns to its initial copied-from-x state, and the
;;; copy can be uncomputed by CX-from-x.
;;;
;;; That's exactly the pattern. controlled-add-subtract! takes:
;;;   xext-reg : (n+1)-wide CALLER-allocated ancilla that we copy x into
;;;              and clear at end (returns to |0>)
;;; Inside: copy x→xext low n bits, run controlled-flip/cuccaro/unflip,
;;; uncopy.

(define (controlled-add-subtract-fast-borrowed! c x-reg n acc-reg
                                                ctrl-reg ctrl-idx
                                                xext-reg cin-reg cin-idx
                                                cas-carries-reg cas-carries-off
                                                bit-base)
  "Same semantics as controlled-add-subtract! but Stage-3 cuccaro-add
   replaced with cuccaro-add-fast-borrowed! using caller-supplied carries.
   cas-carries-reg[cas-carries-off..cas-carries-off+n) must be |0> in/out.
   bit-base..bit-base+n-1 reserved for HMR uncompute classical bits."
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1))))
  (gate-x! c ctrl-reg ctrl-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  (cuccaro-add-offset-fast-borrowed! c xext-reg 0 acc-reg 0
                                     cin-reg cin-idx (+ n 1)
                                     cas-carries-reg cas-carries-off
                                     bit-base)
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-x! c ctrl-reg ctrl-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1)))))

(define (controlled-add-subtract-inverse-fast-borrowed!
         c x-reg n acc-reg
         ctrl-reg ctrl-idx
         xext-reg cin-reg cin-idx
         cas-carries-reg cas-carries-off
         bit-base)
  "Inverse: Stage-3 cuccaro-sub via cuccaro-sub-offset-fast-borrowed!."
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1))))
  (gate-x! c ctrl-reg ctrl-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  (cuccaro-sub-offset-fast-borrowed! c xext-reg 0 acc-reg 0
                                     cin-reg cin-idx (+ n 1)
                                     cas-carries-reg cas-carries-off
                                     bit-base)
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-x! c ctrl-reg ctrl-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1)))))

(define (controlled-add-subtract! c x-reg n acc-reg
                                  ctrl-reg ctrl-idx
                                  xext-reg cin-reg cin-idx)
  "acc := ctrl ? (acc + x) : (acc - x), mod 2^(n+1).
   acc-reg has width n+1. xext-reg has width n+1, |0> in/out.
   x-reg preserved. cin |0> in/out."
  ;; Stage 1: copy x into xext low n bits. xext[n] stays |0>.
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1))))
  ;; Stage 2: condition the add as add-or-subtract.
  ;;   x(ctrl); for k in 0..n: cx(ctrl, xext[k]); cx(ctrl, cin)
  (gate-x! c ctrl-reg ctrl-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  ;; Stage 3: cuccaro add of xext into acc (width n+1).
  (cuccaro-add! c xext-reg acc-reg cin-reg cin-idx (+ n 1))
  ;; Stage 4: undo conditioning.
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-x! c ctrl-reg ctrl-idx)
  ;; Stage 5: uncopy x from xext (low n bits) — CX self-inverse.
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1)))))

(define (controlled-add-subtract-inverse! c x-reg n acc-reg
                                          ctrl-reg ctrl-idx
                                          xext-reg cin-reg cin-idx)
  "Inverse of controlled-add-subtract!: swap add/sub semantics."
  ;; Walk the forward gates in reverse with each step inverted. Stage 1
  ;; (CX copy) is self-inverse → emit at end. Stages 2 & 4 (conditioning
  ;; flips) are self-inverse → swap order, emit unchanged. Stage 3 — the
  ;; cuccaro-add becomes cuccaro-sub.
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1))))
  (gate-x! c ctrl-reg ctrl-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  ;; INVERSE of cuccaro-add at width n+1.
  (cuccaro-sub! c xext-reg acc-reg cin-reg cin-idx (+ n 1))
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-x! c ctrl-reg ctrl-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1)))))

;;; ── slice cuccaro-add variants ────────────────────────────────
;;;
;;; The Litinski schoolbook needs to operate on a SLICE wide[k..k+n+1] as
;;; the accumulator. Our base cuccaro-add! always indexes (acc-reg, 0..n).
;;; We need an offset-indexed version: cuccaro-add-offset! treats the
;;; accumulator as acc-reg starting at bit offset `off`, width `n`.

(define (maj-off! c x-reg x-idx y-reg y-idx w-reg w-idx)
  (maj! c x-reg x-idx y-reg y-idx w-reg w-idx))

;;; *cas-borrowed-carries-reg* / *cas-borrowed-carries-offset* /
;;; *cas-borrowed-bit-base* — when reg is not #f, cuccaro-add-offset!
;;; (& -sub-offset!) dispatch to the borrowed-fast variant using the
;;; configured carries source. Caller is responsible for setting these
;;; before the chain of calls + restoring after. Carries must be |0>
;;; in/out. Bit-base must be a safe-to-clobber starting ID.

(define *cas-borrowed-carries-reg*    #f)
(define *cas-borrowed-carries-offset* 0)
(define *cas-borrowed-bit-base*       0)

;;; *cas-borrowed-bit-base-next* — per-call monotonic counter for HMR slot
;;; allocation in the borrowed offset-fast variants. 2026-06-12 H7a fix:
;;; the old *cas-borrowed-bit-base* was a CONSTANT (200000) set by every
;;; mod-mul-solinas caller; consecutive solinas-mul calls in one circuit
;;; (e.g. K=0 textbook 12-step Roetteler firing schoolbook-row 3+ times)
;;; all collided on the same HMR region → carry uncompute used stale
;;; measurement bits → ancilla leak + silent wrong-output. Same defect
;;; class as *cadd-direct-bit-base* (cdtf-alloc-bit-base! mod-arith.lsp:1709).
;;;
;;; cas-alloc-bit-base!(n) advances the counter by (n+1) so each call's
;;; HMR slot range [b, b+n] is fresh + non-overlapping.

(define *cas-borrowed-bit-base-next* 200000)

(define (cas-alloc-bit-base! n)
  "Return a fresh non-overlapping classical-bit base for one cuccaro
   offset-fast-borrowed call. Advances the counter by (n+1)."
  (let ((b *cas-borrowed-bit-base-next*))
    (set! *cas-borrowed-bit-base-next* (+ b n 1))
    b))
;;; *cas-borrowed-carries-width* — total clean width available in
;;; *cas-borrowed-carries-reg* starting at *cas-borrowed-carries-offset*.
;;; JOINT dispatchers (cuccaro-add-joint! / cuccaro-sub-joint!) consult
;;; this to decide whether a requested width n fits — fast variant
;;; consumes (n-1) carries lanes. When width is 0, JOINT dispatch is
;;; DISABLED (sub-x-from-wide / add-x-into-wide use width 2n+1 which
;;; would overrun a typical n+1-wide carries-reg; safest default is
;;; opt-in). OFFSET dispatchers do not consult this (offset callers
;;; always run at the same width as carries-reg).
(define *cas-borrowed-carries-width*  0)

(define (cuccaro-add-offset! c a-reg a-off acc-reg acc-off cin-reg cin-idx n)
  "acc[off..off+n) := (acc[off..off+n) + a[a-off..a-off+n)) mod 2^n.
   a-reg untouched; cin |0> in/out.
   When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c cin-reg cin-idx acc-reg acc-off)
     (gate-cx! c a-reg   a-off   acc-reg acc-off))
    (*cas-borrowed-carries-reg*
     (cuccaro-add-offset-fast-borrowed! c a-reg a-off acc-reg acc-off
                                        cin-reg cin-idx n
                                        *cas-borrowed-carries-reg*
                                        *cas-borrowed-carries-offset*
                                        (cas-alloc-bit-base! n)))
    (else
     (maj! c cin-reg cin-idx acc-reg acc-off a-reg a-off)
     (let loop ((i 1))
       (when (< i (- n 1))
         (maj! c a-reg (+ a-off (- i 1))
                 acc-reg (+ acc-off i)
                 a-reg (+ a-off i))
         (loop (+ i 1))))
     (gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1)))
     (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1)))
     (let loop ((i (- n 2)))
       (when (>= i 1)
         (uma! c a-reg (+ a-off (- i 1))
                 acc-reg (+ acc-off i)
                 a-reg (+ a-off i))
         (loop (- i 1))))
     (uma! c cin-reg cin-idx acc-reg acc-off a-reg a-off))))

(define (cuccaro-sub-offset! c a-reg a-off acc-reg acc-off cin-reg cin-idx n)
  "Inverse of cuccaro-add-offset!.
   When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c a-reg   a-off   acc-reg acc-off)
     (gate-cx! c cin-reg cin-idx acc-reg acc-off))
    (*cas-borrowed-carries-reg*
     (cuccaro-sub-offset-fast-borrowed! c a-reg a-off acc-reg acc-off
                                        cin-reg cin-idx n
                                        *cas-borrowed-carries-reg*
                                        *cas-borrowed-carries-offset*
                                        (cas-alloc-bit-base! n)))
    (else
     (inv-uma! c cin-reg cin-idx acc-reg acc-off a-reg a-off)
     (let loop ((i 1))
       (when (< i (- n 1))
         (inv-uma! c a-reg (+ a-off (- i 1))
                     acc-reg (+ acc-off i)
                     a-reg (+ a-off i))
         (loop (+ i 1))))
     (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1)))
     (gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1)))
     (let loop ((i (- n 2)))
       (when (>= i 1)
         (inv-maj! c a-reg (+ a-off (- i 1))
                     acc-reg (+ acc-off i)
                     a-reg (+ a-off i))
         (loop (- i 1))))
     (inv-maj! c cin-reg cin-idx acc-reg acc-off a-reg a-off))))

;;; ── cuccaro-add/sub-offset-fast-borrowed! — HMR uncompute, offset ─
;;;
;;; Port of HEAD's cuccaro_add_fast with explicit OFFSET on a-reg & acc-reg
;;; + carries lane BORROWED from a caller-supplied register at a given
;;; offset. Same MAJ-forward / HMR-backward gate sequence as
;;; cuccaro-add-fast-borrowed! (adder.lsp:203) but every a/acc index is
;;; translated through a-off/acc-off.
;;;
;;; Pre: carries-reg[carries-offset..carries-offset+n-2) must be |0> on entry.
;;; Post: carries-reg returns to |0>; a-reg + cin-reg unchanged;
;;;       acc-reg[acc-off..acc-off+n) := (acc + a) mod 2^n.
;;; bit-base..bit-base+n-2 are the classical-bit IDs used by HMR uncompute.

(define (cuccaro-add-offset-fast-borrowed! c a-reg a-off acc-reg acc-off
                                           cin-reg cin-idx n
                                           carries-reg carries-offset
                                           bit-base)
  "Offset+borrowed-carries port of cuccaro-add-fast-borrowed!."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c cin-reg cin-idx acc-reg acc-off)
     (gate-cx! c a-reg   a-off   acc-reg acc-off))
    (else
     (gate-cx!  c a-reg a-off acc-reg acc-off)
     (gate-cx!  c a-reg a-off cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx acc-reg acc-off
                  carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset a-reg a-off)
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (gate-cx!  c a-reg (+ a-off i) acc-reg (+ acc-off i))
         (gate-cx!  c a-reg (+ a-off i) a-reg (+ a-off (- i 1)))
         (gate-ccx! c a-reg (+ a-off (- i 1))
                      acc-reg (+ acc-off i)
                      carries-reg (+ carries-offset i))
         (gate-cx!  c carries-reg (+ carries-offset i) a-reg (+ a-off i))
         (loop-fwd (+ i 1))))
     (gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1)))
     (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1)))
     (let loop-back ((i (- n 2)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i)
                             a-reg (+ a-off i))
         (gate-hmr!        c carries-reg (+ carries-offset i)
                             (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c a-reg (+ a-off (- i 1))
                             acc-reg (+ acc-off i))
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg (+ a-off i) a-reg (+ a-off (- i 1)))
         (gate-cx!         c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i))
         (loop-back (- i 1))))
     (gate-cx!         c carries-reg carries-offset a-reg a-off)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx acc-reg acc-off)
     (gate-pop-cond!   c)
     (gate-cx!         c a-reg a-off cin-reg cin-idx)
     (gate-cx!         c cin-reg cin-idx acc-reg acc-off))))

(define (cuccaro-sub-offset-fast-borrowed! c a-reg a-off acc-reg acc-off
                                           cin-reg cin-idx n
                                           carries-reg carries-offset
                                           bit-base)
  "Offset+borrowed-carries port of cuccaro-sub-fast-borrowed!.
   acc[acc-off..acc-off+n) := (acc - a - cin) mod 2^n."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c a-reg   a-off   acc-reg acc-off)
     (gate-cx! c cin-reg cin-idx acc-reg acc-off))
    (else
     (gate-cx!  c cin-reg cin-idx acc-reg acc-off)
     (gate-cx!  c a-reg a-off cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx acc-reg acc-off
                  carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset a-reg a-off)
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (gate-cx!  c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i))
         (gate-cx!  c a-reg (+ a-off i) a-reg (+ a-off (- i 1)))
         (gate-ccx! c a-reg (+ a-off (- i 1))
                      acc-reg (+ acc-off i)
                      carries-reg (+ carries-offset i))
         (gate-cx!  c carries-reg (+ carries-offset i) a-reg (+ a-off i))
         (loop-fwd (+ i 1))))
     (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1)))
     (gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1)))
     (let loop-back ((i (- n 2)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i)
                             a-reg (+ a-off i))
         (gate-hmr!        c carries-reg (+ carries-offset i)
                             (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c a-reg (+ a-off (- i 1))
                             acc-reg (+ acc-off i))
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg (+ a-off i) a-reg (+ a-off (- i 1)))
         (gate-cx!         c a-reg (+ a-off i) acc-reg (+ acc-off i))
         (loop-back (- i 1))))
     (gate-cx!         c carries-reg carries-offset a-reg a-off)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx acc-reg acc-off)
     (gate-pop-cond!   c)
     (gate-cx!         c a-reg a-off cin-reg cin-idx)
     (gate-cx!         c a-reg a-off acc-reg acc-off))))

;;; *cuccaro-callers-fast* — substrate flag. When #t, controlled-add-subtract!
;;; / controlled-add-subtract-slice! dispatch their inner cuccaro-add at
;;; n+1 width to the borrowed-fast variant. Caller (schoolbook-mul) must
;;; pass a pre-allocated cas-carries register of width n+1 (clean |0>)
;;; & a bit-base integer.

(define *cuccaro-callers-fast* #f)

;;; ── controlled-add-subtract on an OFFSET slice of acc ─────────
;;;
;;; Same semantics as controlled-add-subtract! but the (n+1)-bit acc
;;; lives at acc-reg[acc-off..acc-off+n+1). x stays at x-reg[0..n).

(define (controlled-add-subtract-slice! c x-reg n acc-reg acc-off
                                        ctrl-reg ctrl-idx
                                        xext-reg cin-reg cin-idx)
  "acc[acc-off..acc-off+n+1) := ctrl ? (+x) : (-x), mod 2^(n+1)."
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1))))
  (gate-x! c ctrl-reg ctrl-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  (cuccaro-add-offset! c xext-reg 0 acc-reg acc-off cin-reg cin-idx (+ n 1))
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-x! c ctrl-reg ctrl-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1)))))

(define (controlled-add-subtract-slice-inverse! c x-reg n acc-reg acc-off
                                                ctrl-reg ctrl-idx
                                                xext-reg cin-reg cin-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1))))
  (gate-x! c ctrl-reg ctrl-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  (cuccaro-sub-offset! c xext-reg 0 acc-reg acc-off cin-reg cin-idx (+ n 1))
  (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c ctrl-reg ctrl-idx xext-reg k)
      (loop (+ k 1))))
  (gate-x! c ctrl-reg ctrl-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1)))))

;;; ── slice add-of-classical-constant (offset variant of add-const!) ─

(define (load-const-offset! c reg off n k)
  "reg[off..off+n) ^= bit pattern of k mod 2^n."
  (let ((kk (modulo k (expt 2 n))))
    (let loop ((i 0))
      (when (< i n)
        (when (bit-set? kk i) (gate-x! c reg (+ off i)))
        (loop (+ i 1))))))

(define (add-const-slice! c acc-reg acc-off n k cin-reg cin-idx tmp-reg)
  "acc[acc-off..acc-off+n) += k mod 2^n. tmp-reg n-wide |0> in/out."
  (let ((kk (modulo k (expt 2 n))))
    (load-const!         c tmp-reg n kk)
    (cuccaro-add-offset! c tmp-reg 0 acc-reg acc-off cin-reg cin-idx n)
    (unload-const!       c tmp-reg n kk)))

(define (sub-const-slice! c acc-reg acc-off n k cin-reg cin-idx tmp-reg)
  (let ((kk (modulo k (expt 2 n))))
    (load-const!         c tmp-reg n kk)
    (cuccaro-sub-offset! c tmp-reg 0 acc-reg acc-off cin-reg cin-idx n)
    (unload-const!       c tmp-reg n kk)))

;;; ── Litinski wide schoolbook: tmp-ext (2n bits) += x*y ─────────
;;;
;;; tmp-ext starts |0> n+1=… caller allocates 2n-wide tmp-ext + a 1-wide
;;; low ancilla. We treat wide = [low ++ tmp-ext] as a (2n+1)-bit
;;; accumulator. After all ops, wide = 2*x*y, so x*y reads out at
;;; wide[1..2n+1] = tmp-ext.
;;;
;;; This implementation allocates internal scratch (xext for the
;;; add-subtract loop, plus a cin for the corrections) inline.

(define (schoolbook-mul-into-addsub! c x-reg y-reg n
                                     low-reg low-idx
                                     tmp-ext-reg
                                     xext-reg cin-reg cin-idx
                                     const-tmp-reg)
  "Compute wide = [low ++ tmp-ext] := 2 * x * y over (2n+1) bits.
   x-reg, y-reg are n-wide and preserved. tmp-ext is 2n-wide |0> in.
   xext-reg is (n+1)-wide ancilla |0> in/out (controlled-add-subtract
   scratch). const-tmp-reg is (n+1)-wide ancilla |0> in/out (constant
   loading scratch). low is 1 bit |0> in/out (top of wide). cin is 1
   bit |0> in/out. After: tmp-ext = x*y (2n bits)."
  ;; ─ n controlled add-subtracts on offset slices of wide ─
  ;; wide[k..k+n+1) — when k=0, wide[0]=low, wide[1..n+1)=tmp-ext[0..n).
  ;; When k>=1, wide[k..k+n+1) sits entirely in tmp-ext[k-1..k+n).
  ;; So we split: k=0 uses [low ++ tmp-ext[0..n)] as the slice,
  ;; k>=1 uses tmp-ext[k-1..k+n) directly.
  (let loop ((k 0))
    (when (< k n)
      (cond
        ((= k 0)
         ;; Slice = [low(idx low-idx) ++ tmp-ext[0..n)]. We can't represent
         ;; that as a single offset register, so we hand-code: copy x into
         ;; xext, condition-flip, then run a SPECIAL cuccaro that uses
         ;; low at bit 0 and tmp-ext at bits 1..n+1. Easier alternative:
         ;; allocate a fresh (n+1)-wide buffer "wide0" that is
         ;; pre-correlated to [low, tmp-ext[0..n)] via CX, run the slice
         ;; add into wide0, then uncorrelate. But that re-introduces the
         ;; aliasing problem.
         ;;
         ;; Cleanest fix: implement controlled-add-subtract to take a
         ;; CALLBACK or two-register slice spec. Even simpler: at k=0,
         ;; since low starts |0>, the slice is [|0>, tmp-ext[0..n)] — i.e.
         ;; treat the slice as tmp-ext[0..n) padded with low at TOP. But
         ;; Litinski needs low at the BOTTOM of the slice.
         ;;
         ;; Workaround: split the k=0 step into two: first do a
         ;; controlled-add-subtract on the LOW bit (low alone, x[0] only),
         ;; then handle bits 1..n+1 via the regular tmp-ext slice.
         ;; That breaks the algorithm — the carries chain through.
         ;;
         ;; Real fix: use a JOINT cuccaro across (low, tmp-ext[0..n)).
         ;; Implement schoolbook-row-k0! inline using offset CX/MAJ ops
         ;; that explicitly reference low at index 0 and tmp-ext at
         ;; indices 0..n-1 (treated as positions 1..n of the slice).
         (schoolbook-row-k0! c x-reg n
                             y-reg k
                             low-reg low-idx
                             tmp-ext-reg
                             xext-reg cin-reg cin-idx))
        (else
         ;; Slice lives entirely in tmp-ext at offset (k-1), width n+1.
         (controlled-add-subtract-slice! c x-reg n
                                         tmp-ext-reg (- k 1)
                                         y-reg k
                                         xext-reg cin-reg cin-idx)))
      (loop (+ k 1))))
  ;; ─ Correction 1: wide[n..2n+1) += 2^0 * (y + 1), via cuccaro-add of
  ;;   y_ext = y ++ pad(=0) with c_in=1. wide[n..2n+1) = tmp-ext[n-1..2n).
  ;;   Set cin=1 via X, run cuccaro-add-offset over (n+1) bits, X cin back.
  (gate-x! c cin-reg cin-idx)
  (cuccaro-add-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg cin-reg cin-idx
                                  const-tmp-reg)
  (gate-x! c cin-reg cin-idx)
  ;; ─ Correction 2: wide[2n] ^= 1 → tmp-ext[2n-1] ^= 1.
  (gate-x! c tmp-ext-reg (- (* 2 n) 1))
  ;; ─ Correction 3: -x over the FULL (2n+1)-bit wide. Hand-code as a
  ;;   cuccaro-sub joint over [low ++ tmp-ext] with x at low bits, zeros
  ;;   above. We use const-tmp-reg padded with zeros as a (2n+1)-wide
  ;;   source... but it's only n+1 wide.
  ;;
  ;;   Simpler: -x is just n bits of x at the bottom of wide. The high
  ;;   bits beyond x's range are zero. cuccaro-sub on a width-(2n+1)
  ;;   source where bits n..2n are |0> still works (zero high bits are a
  ;;   noop for MAJ/UMA — they just propagate the carry).
  ;;
  ;;   We don't actually need extra register width: emit a "sub x into
  ;;   wide" routine that walks bits 0..n of x and bits n..2n+1 of wide
  ;;   as |0> source bits (no gate needed — they have no effect since the
  ;;   MAJ/UMA cells with x_high=0 reduce to identity on the wide bit).
  ;;
  ;;   Actually that's still wrong — the carry chain still propagates
  ;;   through high bits. We need an honest cuccaro-sub with the full
  ;;   width. Use a TEMP (2n+1)-wide source register: alloc xfull, copy
  ;;   x into xfull[0..n), run cuccaro-sub-offset of xfull into wide,
  ;;   uncopy x. But alloc inside is fine.
  (sub-x-from-wide! c x-reg n low-reg low-idx tmp-ext-reg cin-reg cin-idx)
  ;; ─ Correction 4: wide[n..2n+1) += 2^0 * x, via cuccaro-add of x_ext
  ;;   (x ++ pad(=0)) with c_in=0. wide[n..2n+1) = tmp-ext[n-1..2n).
  (cuccaro-add-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg cin-reg cin-idx
                                  const-tmp-reg))

;;; ── helpers used by schoolbook-mul-into-addsub! ──────────────

(define (schoolbook-row-k0! c x-reg n y-reg y-idx
                            low-reg low-idx tmp-ext-reg
                            xext-reg cin-reg cin-idx)
  "k=0 row of Litinski: controlled-add-subtract on slice
   [low ++ tmp-ext[0..n)] of width n+1, controlled on y[y-idx].
   We need a Cuccaro-add over a JOINT register (low at bit 0, tmp-ext
   at bits 1..n). Emit inline using MAJ/UMA primitives with explicit
   bit refs."
  ;; xext = ctrl ? ~x[0..n) : x[0..n)
  ;; cin  = ctrl ? 1 : 0
  ;; Then cuccaro-add of xext into wide (treating wide[0]=low, wide[1..n+1)=tmp-ext[0..n))
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1))))
  (gate-x! c y-reg y-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c y-reg y-idx xext-reg k)
      (loop (+ k 1))))
  (gate-cx! c y-reg y-idx cin-reg cin-idx)
  ;; Joint cuccaro-add: source xext (n+1 wide, all in xext-reg), target
  ;; "wide" where wide[0]=(low,low-idx), wide[i+1]=(tmp-ext-reg, i) for i in 0..n-1.
  ;; Use a Cuccaro that selects target bits via a small switch.
  (cuccaro-add-joint! c xext-reg 0
                      low-reg low-idx tmp-ext-reg 0
                      cin-reg cin-idx (+ n 1))
  (gate-cx! c y-reg y-idx cin-reg cin-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c y-reg y-idx xext-reg k)
      (loop (+ k 1))))
  (gate-x! c y-reg y-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1)))))

;;; Cuccaro-add where the ACCUMULATOR spans two registers: bit 0 lives
;;; at (low-reg, low-idx), bits 1..n-1 live at (mid-reg, mid-off..mid-off+n-2).
;;; Source register has width n, contiguous in src-reg at offset src-off.

(define (joint-acc-ref low-reg low-idx mid-reg mid-off i)
  "Return (reg idx) for bit i of the joint accumulator."
  (if (= i 0)
      (list low-reg low-idx)
      (list mid-reg (+ mid-off (- i 1)))))

(define (cuccaro-add-joint! c src-reg src-off
                            low-reg low-idx mid-reg mid-off
                            cin-reg cin-idx n)
  "acc[0..n) := acc[0..n) + src[src-off..src-off+n), where acc[0]=(low,low-idx)
   and acc[i]=(mid-reg, mid-off+i-1) for i>=1. n>=1.
   When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path."
  (cond
    ((= n 1)
     (gate-cx! c cin-reg cin-idx low-reg low-idx)
     (gate-cx! c src-reg src-off low-reg low-idx))
    ((and *cas-borrowed-carries-reg*
          (> *cas-borrowed-carries-width* 0)
          (<= (- n 1) *cas-borrowed-carries-width*))
     (cuccaro-add-joint-fast-borrowed! c src-reg src-off
                                       low-reg low-idx mid-reg mid-off
                                       cin-reg cin-idx n
                                       *cas-borrowed-carries-reg*
                                       *cas-borrowed-carries-offset*
                                       (cas-alloc-bit-base! n)))
    (else
     ;; MAJ(cin, acc[0], src[0]) — acc[0] = (low, low-idx)
     (maj! c cin-reg cin-idx low-reg low-idx src-reg src-off)
     (let loop ((i 1))
       (when (< i (- n 1))
         ;; MAJ(src[i-1], acc[i], src[i])
         (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
           (maj! c src-reg (+ src-off (- i 1))
                   (car acc-i) (car (cdr acc-i))
                   src-reg (+ src-off i)))
         (loop (+ i 1))))
     ;; Final sum bit: acc[n-1] = (mid, mid-off+n-2) since n>=2
     (let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1))))
       (gate-cx! c src-reg (+ src-off (- n 2))
                   (car acc-top) (car (cdr acc-top)))
       (gate-cx! c src-reg (+ src-off (- n 1))
                   (car acc-top) (car (cdr acc-top))))
     ;; Reverse UMA sweep
     (let loop ((i (- n 2)))
       (when (>= i 1)
         (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
           (uma! c src-reg (+ src-off (- i 1))
                   (car acc-i) (car (cdr acc-i))
                   src-reg (+ src-off i)))
         (loop (- i 1))))
     (uma! c cin-reg cin-idx low-reg low-idx src-reg src-off))))

(define (cuccaro-sub-joint! c src-reg src-off
                            low-reg low-idx mid-reg mid-off
                            cin-reg cin-idx n)
  "Inverse of cuccaro-add-joint!.
   When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path."
  (cond
    ((= n 1)
     (gate-cx! c src-reg src-off low-reg low-idx)
     (gate-cx! c cin-reg cin-idx low-reg low-idx))
    ((and *cas-borrowed-carries-reg*
          (> *cas-borrowed-carries-width* 0)
          (<= (- n 1) *cas-borrowed-carries-width*))
     (cuccaro-sub-joint-fast-borrowed! c src-reg src-off
                                       low-reg low-idx mid-reg mid-off
                                       cin-reg cin-idx n
                                       *cas-borrowed-carries-reg*
                                       *cas-borrowed-carries-offset*
                                       (cas-alloc-bit-base! n)))
    (else
     (inv-uma! c cin-reg cin-idx low-reg low-idx src-reg src-off)
     (let loop ((i 1))
       (when (< i (- n 1))
         (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
           (inv-uma! c src-reg (+ src-off (- i 1))
                       (car acc-i) (car (cdr acc-i))
                       src-reg (+ src-off i)))
         (loop (+ i 1))))
     (let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1))))
       (gate-cx! c src-reg (+ src-off (- n 1))
                   (car acc-top) (car (cdr acc-top)))
       (gate-cx! c src-reg (+ src-off (- n 2))
                   (car acc-top) (car (cdr acc-top))))
     (let loop ((i (- n 2)))
       (when (>= i 1)
         (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
           (inv-maj! c src-reg (+ src-off (- i 1))
                       (car acc-i) (car (cdr acc-i))
                       src-reg (+ src-off i)))
         (loop (- i 1))))
     (inv-maj! c cin-reg cin-idx low-reg low-idx src-reg src-off))))

;;; ── cuccaro-add/sub-joint-fast-borrowed! — HMR uncompute, joint acc ─
;;;
;;; Port of HEAD's cuccaro_add_fast pattern to the JOINT accumulator
;;; layout used by schoolbook-row-k0! + sub-x-from-wide!. acc[0] lives
;;; at (low-reg, low-idx); acc[i] for i>=1 lives at (mid-reg, mid-off+i-1).
;;; Source register is contiguous src-reg[src-off..src-off+n).
;;;
;;; Same MAJ-forward / HMR-backward gate sequence as
;;; cuccaro-add-offset-fast-borrowed! (mod-arith.lsp:651) — every acc[i]
;;; reference is translated through joint-acc-ref. src/cin indexing
;;; matches the offset variant exactly (contiguous source).
;;;
;;; Pre: carries-reg[carries-offset..carries-offset+n-2) must be |0> on entry.
;;; Post: carries-reg returns to |0>; src-reg + cin-reg unchanged;
;;;       joint acc[0..n) := (acc + src) mod 2^n.
;;; bit-base..bit-base+n-2 are the classical-bit IDs used by HMR uncompute.

(define (cuccaro-add-joint-fast-borrowed! c src-reg src-off
                                          low-reg low-idx mid-reg mid-off
                                          cin-reg cin-idx n
                                          carries-reg carries-offset
                                          bit-base)
  "Joint-acc + borrowed-carries port of cuccaro-add-fast-borrowed!.
   acc[0]=(low,low-idx); acc[i>=1]=(mid-reg, mid-off+i-1)."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c cin-reg cin-idx low-reg low-idx)
     (gate-cx! c src-reg src-off low-reg low-idx))
    (else
     ;; Forward step i=0: acc[0] = (low, low-idx); src[0]; cin
     (gate-cx!  c src-reg src-off low-reg low-idx)
     (gate-cx!  c src-reg src-off cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx low-reg low-idx
                  carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset src-reg src-off)
     ;; Forward steps i=1..n-2: acc[i] = (mid-reg, mid-off+i-1)
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
           (gate-cx!  c src-reg (+ src-off i)
                        (car acc-i) (car (cdr acc-i)))
           (gate-cx!  c src-reg (+ src-off i) src-reg (+ src-off (- i 1)))
           (gate-ccx! c src-reg (+ src-off (- i 1))
                        (car acc-i) (car (cdr acc-i))
                        carries-reg (+ carries-offset i))
           (gate-cx!  c carries-reg (+ carries-offset i)
                        src-reg (+ src-off i)))
         (loop-fwd (+ i 1))))
     ;; Final sum bit: acc[n-1] = (mid, mid-off+n-2) for n>=2
     (let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1))))
       (gate-cx! c src-reg (+ src-off (- n 2))
                   (car acc-top) (car (cdr acc-top)))
       (gate-cx! c src-reg (+ src-off (- n 1))
                   (car acc-top) (car (cdr acc-top))))
     ;; Backward HMR uncompute, i = n-2..1
     (let loop-back ((i (- n 2)))
       (when (>= i 1)
         (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
           (gate-cx!         c carries-reg (+ carries-offset i)
                               src-reg (+ src-off i))
           (gate-hmr!        c carries-reg (+ carries-offset i)
                               (+ bit-base i))
           (gate-push-cond!  c (+ bit-base i))
           (gate-cz!         c src-reg (+ src-off (- i 1))
                               (car acc-i) (car (cdr acc-i)))
           (gate-pop-cond!   c)
           (gate-cx!         c src-reg (+ src-off i) src-reg (+ src-off (- i 1)))
           (gate-cx!         c src-reg (+ src-off (- i 1))
                               (car acc-i) (car (cdr acc-i))))
         (loop-back (- i 1))))
     ;; Backward HMR i=0: acc[0] = (low, low-idx)
     (gate-cx!         c carries-reg carries-offset src-reg src-off)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx low-reg low-idx)
     (gate-pop-cond!   c)
     (gate-cx!         c src-reg src-off cin-reg cin-idx)
     (gate-cx!         c cin-reg cin-idx low-reg low-idx))))

(define (cuccaro-sub-joint-fast-borrowed! c src-reg src-off
                                          low-reg low-idx mid-reg mid-off
                                          cin-reg cin-idx n
                                          carries-reg carries-offset
                                          bit-base)
  "Joint-acc + borrowed-carries port of cuccaro-sub-fast-borrowed!.
   acc[0..n) := (acc - src - cin) mod 2^n."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c src-reg src-off low-reg low-idx)
     (gate-cx! c cin-reg cin-idx low-reg low-idx))
    (else
     ;; Forward inv-UMA-like at i=0
     (gate-cx!  c cin-reg cin-idx low-reg low-idx)
     (gate-cx!  c src-reg src-off cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx low-reg low-idx
                  carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset src-reg src-off)
     ;; Forward steps i=1..n-2
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
           (gate-cx!  c src-reg (+ src-off (- i 1))
                        (car acc-i) (car (cdr acc-i)))
           (gate-cx!  c src-reg (+ src-off i) src-reg (+ src-off (- i 1)))
           (gate-ccx! c src-reg (+ src-off (- i 1))
                        (car acc-i) (car (cdr acc-i))
                        carries-reg (+ carries-offset i))
           (gate-cx!  c carries-reg (+ carries-offset i)
                        src-reg (+ src-off i)))
         (loop-fwd (+ i 1))))
     ;; Final sum bit — sub order swaps the two CXs
     (let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1))))
       (gate-cx! c src-reg (+ src-off (- n 1))
                   (car acc-top) (car (cdr acc-top)))
       (gate-cx! c src-reg (+ src-off (- n 2))
                   (car acc-top) (car (cdr acc-top))))
     ;; Backward HMR uncompute, i = n-2..1
     (let loop-back ((i (- n 2)))
       (when (>= i 1)
         (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
           (gate-cx!         c carries-reg (+ carries-offset i)
                               src-reg (+ src-off i))
           (gate-hmr!        c carries-reg (+ carries-offset i)
                               (+ bit-base i))
           (gate-push-cond!  c (+ bit-base i))
           (gate-cz!         c src-reg (+ src-off (- i 1))
                               (car acc-i) (car (cdr acc-i)))
           (gate-pop-cond!   c)
           (gate-cx!         c src-reg (+ src-off i) src-reg (+ src-off (- i 1)))
           (gate-cx!         c src-reg (+ src-off i)
                               (car acc-i) (car (cdr acc-i))))
         (loop-back (- i 1))))
     ;; Backward HMR i=0
     (gate-cx!         c carries-reg carries-offset src-reg src-off)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx low-reg low-idx)
     (gate-pop-cond!   c)
     (gate-cx!         c src-reg src-off cin-reg cin-idx)
     (gate-cx!         c src-reg src-off low-reg low-idx))))

;;; Correction 1 helper: wide[n..2n+1) += y_ext where y_ext = y at bits
;;; [0..n) and pad(=0) at bit n. We need to cuccaro-add the y bits into
;;; a (n+1)-wide slice of wide at offset n. wide[n] = tmp-ext[n-1].
;;; wide[n+1..2n+1) = tmp-ext[n..2n).
;;;
;;; This is the SAME joint accumulator pattern: target bit 0 = (tmp-ext,
;;; n-1), target bits 1..n = (tmp-ext, n..2n-1). Adjacent indices —
;;; really a SINGLE register slice tmp-ext[n-1..2n).
;;;
;;; Source y_ext: we need n+1 bits where y_ext[0..n) = y and y_ext[n] = 0.
;;; We use const-tmp-reg (n+1 wide |0>) as y_ext: copy y into bits [0..n),
;;; run cuccaro-add-offset of const-tmp into tmp-ext at offset n-1 width
;;; n+1, then uncopy y.

(define (cuccaro-add-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg
                                        cin-reg cin-idx const-tmp-reg)
  "wide[n..2n+1) += y_ext with c_in present.
   wide[n..2n+1) = tmp-ext[n-1..2n)."
  ;; Copy y → const-tmp low n bits. const-tmp[n] stays |0> = pad.
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c y-reg k const-tmp-reg k)
      (loop (+ k 1))))
  ;; cuccaro-add at width n+1 into tmp-ext at offset n-1.
  (cuccaro-add-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1)
                       cin-reg cin-idx (+ n 1))
  ;; Uncopy.
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c y-reg k const-tmp-reg k)
      (loop (+ k 1)))))

(define (cuccaro-sub-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg
                                        cin-reg cin-idx const-tmp-reg)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c y-reg k const-tmp-reg k)
      (loop (+ k 1))))
  (cuccaro-sub-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1)
                       cin-reg cin-idx (+ n 1))
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c y-reg k const-tmp-reg k)
      (loop (+ k 1)))))

(define (cuccaro-add-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg
                                        cin-reg cin-idx const-tmp-reg)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k const-tmp-reg k)
      (loop (+ k 1))))
  (cuccaro-add-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1)
                       cin-reg cin-idx (+ n 1))
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k const-tmp-reg k)
      (loop (+ k 1)))))

(define (cuccaro-sub-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg
                                        cin-reg cin-idx const-tmp-reg)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k const-tmp-reg k)
      (loop (+ k 1))))
  (cuccaro-sub-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1)
                       cin-reg cin-idx (+ n 1))
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k const-tmp-reg k)
      (loop (+ k 1)))))

;;; Correction 3 helper: wide -= x, where wide has width 2n+1 ([low ++ tmp-ext])
;;; and x is at x-reg[0..n). x's high (2n+1-n)=n+1 bits are zero (we pad).
;;;
;;; Use a JOINT cuccaro-sub over the full wide. Source: const-tmp at low
;;; n bits (loaded from x) zero-padded above. But const-tmp is only n+1
;;; wide — we need 2n+1 wide source. We allocate xfull internally.
;;;
;;; *sub-x-from-wide-cas-fast* — sweep-027 opt-in flag. When BOTH
;;; *cuccaro-callers-fast* AND this flag are set, widen sb-xfull to
;;; 4n+1 and dispatch joint via cas-borrowed. Disabled by default
;;; (sweep-027 verdict: knife-edge ROI, +10%% worst-case score).
;;; ALLOC width 4n+1 = 1025 at production hits the n=512 ancilla cap
;;; if cap isnt raised — keep off unless cap is also raised.

(define *sub-x-from-wide-cas-fast* #f)

;;; *sub-x-from-wide-host-alloc* — sweep-036 opt-in flag (allocator
;;; surgery). When set, mod-mul-solinas! / mod-mul-solinas-sub! allocate
;;; sb-xfull at Stage-0 (TOP of their scratch suite, BEFORE sb-tmp-ext /
;;; sb-low / sb-xext / sb-const-tmp) instead of letting sub-x-from-wide!
;;; / add-x-into-wide! allocate it internally on each call. The hoisted
;;; alloc lands at the lowest free 513-wide base inside the mod-mul
;;; scope; sub-x-from-wide! / add-x-into-wide! consult *host-sb-xfull-reg*
;;; & skip their internal alloc when that variable is bound. ZERO Toffoli
;;; delta — same sb-xfull contents, same gate sequence. The opt-in is a
;;; pure register-lifetime re-order: it removes the deep-nested late
;;; allocation that landed sb-xfull on top of the dgcd-host floor.
;;;
;;; Predicted peak qubits change: sweep-035 baseline 5,024 → ~4,510
;;; (−10.2 %) per allocator-replay subagent (runs/lumbda-sweep-032
;;; ALLOCATOR-REPORT-sweep030.md temporal-overlap candidate #2).
;;;
;;; When flag off & *host-sb-xfull-reg* #f, both helpers fall through
;;; their old alloc-internal path — byte-identical to sweep-035.

(define *sub-x-from-wide-host-alloc* #f)

;;; Dynamic variable bound by mod-mul-solinas! / mod-mul-solinas-sub!
;;; when *sub-x-from-wide-host-alloc* is on: holds the host-allocated
;;; sb-xfull register name, communicated to sub-x-from-wide! /
;;; add-x-into-wide! without changing their signatures. Cleared to #f
;;; after the Stage-3 inverse pass so subsequent mod-mul calls outside
;;; the host scope alloc internally again.

(define *host-sb-xfull-reg* #f)

;;; sweep-027: when *cuccaro-callers-fast* is set, widen sb-xfull from
;;; 2n+1 → 4n+1 so the top 2n bits can serve as borrowed carries for the
;;; JOINT fast-borrowed dispatch path:
;;;
;;;   sb-xfull[0..n)        = x data (Stage-1 load)
;;;   sb-xfull[n..2n+1)     = source pad (touched by cuccaro as |0> bits)
;;;   sb-xfull[2n+1..4n+1)  = HMR carries pad (clean |0> on entry/exit)
;;;
;;; Width-N=2n+1 joint fast-borrowed consumes N-1 = 2n carries lanes,
;;; which exactly fits sb-xfull[2n+1..4n+1). Bit-base 300000 disjoint
;;; from mod-solinas' 200000 reservation (which covers up to n+1 bits).
;;; Saves (N-1)-N/2 ≈ N-1 = 2n Toffoli per call via HMR uncompute;
;;; cost is +2n qubits in sb-xfull's transient allocation.

(define (sub-x-from-wide! c x-reg n low-reg low-idx tmp-ext-reg
                          cin-reg cin-idx)
  "wide := wide - x, where wide = [low ++ tmp-ext] (2n+1 bits) and x is
   at x-reg[0..n). High bits of x_padded are 0. Uses internal xfull
   ancilla (alloc'd here; widened to 4n+1 under *cuccaro-callers-fast*
   to host the JOINT fast-borrowed carries).

   When *host-sb-xfull-reg* is bound (sweep-036 opt-in), the caller
   (mod-mul-solinas!) has pre-allocated sb-xfull at outer scope; skip
   internal alloc/free & use the hosted register name."
  (let* ((use-fast?    (and *cuccaro-callers-fast* *sub-x-from-wide-cas-fast*))
         (joint-width  (+ (* 2 n) 1))                  ; N = 2n+1
         (carries-need (- joint-width 1))              ; N-1 = 2n
         (xfull-width  (cond (use-fast? (+ joint-width carries-need))
                             (else      joint-width)))
         (host-reg     *host-sb-xfull-reg*)
         (xfull-name   (cond (host-reg host-reg)
                             (else     (quote sb-xfull)))))
    ;; Allocate xfull (xfull-width bits |0>) — unless hosted by caller.
    (when (not host-reg)
      (alloc! c xfull-name xfull-width))
    (let loop ((k 0))
      (when (< k n)
        (gate-cx! c x-reg k xfull-name k)
        (loop (+ k 1))))
    ;; Configure cas-borrowed for joint dispatch when in fast mode.
    (cond
      (use-fast?
       (let ((saved-reg    *cas-borrowed-carries-reg*)
             (saved-off    *cas-borrowed-carries-offset*)
             (saved-base   *cas-borrowed-bit-base*)
             (saved-width  *cas-borrowed-carries-width*))
         (set! *cas-borrowed-carries-reg*    xfull-name)
         (set! *cas-borrowed-carries-offset* joint-width)
         (set! *cas-borrowed-bit-base*       300000)
         (set! *cas-borrowed-carries-width*  carries-need)
         (cuccaro-sub-joint! c xfull-name 0
                             low-reg low-idx tmp-ext-reg 0
                             cin-reg cin-idx joint-width)
         (set! *cas-borrowed-carries-reg*    saved-reg)
         (set! *cas-borrowed-carries-offset* saved-off)
         (set! *cas-borrowed-bit-base*       saved-base)
         (set! *cas-borrowed-carries-width*  saved-width)))
      (else
       (cuccaro-sub-joint! c xfull-name 0
                           low-reg low-idx tmp-ext-reg 0
                           cin-reg cin-idx joint-width)))
    ;; Uncopy x.
    (let loop ((k 0))
      (when (< k n)
        (gate-cx! c x-reg k xfull-name k)
        (loop (+ k 1))))
    (when (not host-reg)
      (free! c xfull-name))))

(define (add-x-into-wide! c x-reg n low-reg low-idx tmp-ext-reg
                          cin-reg cin-idx)
  "Inverse of sub-x-from-wide!: wide += x over full 2n+1 bits.
   sb-xfull widened to 4n+1 under *cuccaro-callers-fast* to host
   the JOINT fast-borrowed carries pad above the source range.

   When *host-sb-xfull-reg* is bound (sweep-036 opt-in), use the hosted
   register instead of allocating/freeing internally."
  (let* ((use-fast?    (and *cuccaro-callers-fast* *sub-x-from-wide-cas-fast*))
         (joint-width  (+ (* 2 n) 1))
         (carries-need (- joint-width 1))
         (xfull-width  (cond (use-fast? (+ joint-width carries-need))
                             (else      joint-width)))
         (host-reg     *host-sb-xfull-reg*)
         (xfull-name   (cond (host-reg host-reg)
                             (else     (quote sb-xfull)))))
    (when (not host-reg)
      (alloc! c xfull-name xfull-width))
    (let loop ((k 0))
      (when (< k n)
        (gate-cx! c x-reg k xfull-name k)
        (loop (+ k 1))))
    (cond
      (use-fast?
       (let ((saved-reg    *cas-borrowed-carries-reg*)
             (saved-off    *cas-borrowed-carries-offset*)
             (saved-base   *cas-borrowed-bit-base*)
             (saved-width  *cas-borrowed-carries-width*))
         (set! *cas-borrowed-carries-reg*    xfull-name)
         (set! *cas-borrowed-carries-offset* joint-width)
         (set! *cas-borrowed-bit-base*       300000)
         (set! *cas-borrowed-carries-width*  carries-need)
         (cuccaro-add-joint! c xfull-name 0
                             low-reg low-idx tmp-ext-reg 0
                             cin-reg cin-idx joint-width)
         (set! *cas-borrowed-carries-reg*    saved-reg)
         (set! *cas-borrowed-carries-offset* saved-off)
         (set! *cas-borrowed-bit-base*       saved-base)
         (set! *cas-borrowed-carries-width*  saved-width)))
      (else
       (cuccaro-add-joint! c xfull-name 0
                           low-reg low-idx tmp-ext-reg 0
                           cin-reg cin-idx joint-width)))
    (let loop ((k 0))
      (when (< k n)
        (gate-cx! c x-reg k xfull-name k)
        (loop (+ k 1))))
    (when (not host-reg)
      (free! c xfull-name))))

;;; Inverse of schoolbook-mul-into-addsub!: undo each correction then
;;; the loop, gate-by-gate inverted. Self-inverse steps (X) re-emit.

(define (schoolbook-mul-into-addsub-inverse! c x-reg y-reg n
                                             low-reg low-idx
                                             tmp-ext-reg
                                             xext-reg cin-reg cin-idx
                                             const-tmp-reg)
  ;; Reverse correction 4: cuccaro-sub of x_ext at high half.
  (cuccaro-sub-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg cin-reg cin-idx
                                  const-tmp-reg)
  ;; Reverse correction 3: add x back into wide.
  (add-x-into-wide! c x-reg n low-reg low-idx tmp-ext-reg cin-reg cin-idx)
  ;; Reverse correction 2: re-XOR top bit (self-inverse).
  (gate-x! c tmp-ext-reg (- (* 2 n) 1))
  ;; Reverse correction 1: cuccaro-sub of y_ext with cin=1.
  (gate-x! c cin-reg cin-idx)
  (cuccaro-sub-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg cin-reg cin-idx
                                  const-tmp-reg)
  (gate-x! c cin-reg cin-idx)
  ;; Reverse the main loop (k from n-1 down to 0).
  (let loop ((k (- n 1)))
    (when (>= k 0)
      (cond
        ((= k 0)
         (schoolbook-row-k0-inverse! c x-reg n
                                     y-reg k
                                     low-reg low-idx
                                     tmp-ext-reg
                                     xext-reg cin-reg cin-idx))
        (else
         (controlled-add-subtract-slice-inverse! c x-reg n
                                                 tmp-ext-reg (- k 1)
                                                 y-reg k
                                                 xext-reg cin-reg cin-idx)))
      (loop (- k 1)))))

(define (schoolbook-row-k0-inverse! c x-reg n y-reg y-idx
                                    low-reg low-idx tmp-ext-reg
                                    xext-reg cin-reg cin-idx)
  "Inverse of schoolbook-row-k0!."
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1))))
  (gate-x! c y-reg y-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c y-reg y-idx xext-reg k)
      (loop (+ k 1))))
  (gate-cx! c y-reg y-idx cin-reg cin-idx)
  (cuccaro-sub-joint! c xext-reg 0
                      low-reg low-idx tmp-ext-reg 0
                      cin-reg cin-idx (+ n 1))
  (gate-cx! c y-reg y-idx cin-reg cin-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c y-reg y-idx xext-reg k)
      (loop (+ k 1))))
  (gate-x! c y-reg y-idx)
  (let loop ((k 0))
    (when (< k n)
      (gate-cx! c x-reg k xext-reg k)
      (loop (+ k 1)))))

;;; ── mod-mul! — Litinski wide schoolbook + Solinas-style reduction ─
;;;
;;; Calling convention:
;;;   a-reg, b-reg, out-reg : (n+1)-wide; top bit must be |0> on entry
;;;                           (we operate on low n bits only).
;;;                           a-reg, b-reg preserved; out-reg ends with
;;;                           (a*b) mod p.
;;;   cin-reg, cin-idx       : 1 bit |0> in/out (mod-add c_in)
;;;   tmp-reg                : (n+1)-wide |0> in/out — mod-add's inner
;;;                           constant-loading scratch.
;;;   flag-reg, flag-idx     : 1 bit |0> in/out (mod-add flag)
;;;   red-tmp-reg            : (n+1)-wide |0> in/out — used in Stage 2 to
;;;                           load 2^k mod p constants into a register
;;;                           before mod-add into out.
;;;
;;; Inside, mod-mul! allocates its own Litinski scratch:
;;;   sb-tmp-ext  (2n bits)  the wide product accumulator
;;;   sb-low      (1 bit)    wide[0]
;;;   sb-xext     (n+1 bits) controlled-add-subtract scratch
;;;   sb-const-tmp (n+1 bits) correction-stage constant-loading scratch
;;;   sb-xfull    (2n+1 bits, alloc/free'd inside sub-x-from-wide!)

;;; ── Solinas dispatch flag ─────────────────────────────────────
;;;
;;; When *mod-mul-use-solinas* is non-#f, mod-mul! and mod-mul-sub!
;;; dispatch into mod-mul-solinas! / mod-mul-solinas-sub! (defined in
;;; lumbda/mod-solinas.lsp — caller must load that file before flipping
;;; the flag). Caller-visible signatures and ancilla register names
;;; remain identical, so every consumer (mod-inv!, mod-square!,
;;; real-point-add!) inherits the speedup without code change.

(define *mod-mul-use-solinas* #f)

(define (mod-mul! c a-reg b-reg out-reg n+1 p
                  cin-reg cin-idx tmp-reg flag-reg flag-idx
                  red-tmp-reg)
  "out := (a * b) mod p. Litinski schoolbook + per-bit Solinas-style reduce.
   See header for full calling convention.

   When *mod-mul-use-solinas* is non-#f, dispatch to mod-mul-solinas!
   (mod-solinas.lsp must already be loaded)."
  (cond
    (*mod-mul-use-solinas*
     (mod-mul-solinas! c a-reg b-reg out-reg n+1 p
                       (compute-c-expansion p (- n+1 1))
                       cin-reg cin-idx tmp-reg flag-reg flag-idx
                       red-tmp-reg))
    (else
     (mod-mul-litinski! c a-reg b-reg out-reg n+1 p
                        cin-reg cin-idx tmp-reg flag-reg flag-idx
                        red-tmp-reg))))

;;; ── mod-mul-from-zero! — caller-explicit out=|0> specialization ───
;;;
;;; Port of HEAD's `mod_add_qq_fast_from_zero` lifted to the multiply
;;; entry boundary. Caller invokes this INSTEAD of mod-mul! when out-reg
;;; is provably |0> on entry (e.g. mod-square!'s freshly-alloc'd out,
;;; mod-inv-by Fermat ladder's r-next / b-next, point-add lam-reg before
;;; any accumulation).
;;;
;;; Saves n CCX per fresh-multiply when both
;;;   *mod-mul-use-solinas* AND *mod-mul-from-zero-first-add*
;;; are #t. When *mod-mul-from-zero-first-add* off, byte-identical to
;;; mod-mul-solinas! (safe fallback). When *mod-mul-use-solinas* off,
;;; falls through to mod-mul-litinski! (no specialization yet for the
;;; Litinski path — Stage 2 dispatch shape differs).

(define (mod-mul-from-zero! c a-reg b-reg out-reg n+1 p
                            cin-reg cin-idx tmp-reg flag-reg flag-idx
                            red-tmp-reg)
  "out := (a * b) mod p when out is |0> on entry. See mod-mul! header
   for calling convention."
  (cond
    (*mod-mul-use-solinas*
     (mod-mul-solinas-from-zero! c a-reg b-reg out-reg n+1 p
                                 (compute-c-expansion p (- n+1 1))
                                 cin-reg cin-idx tmp-reg flag-reg flag-idx
                                 red-tmp-reg))
    (else
     (mod-mul-litinski! c a-reg b-reg out-reg n+1 p
                        cin-reg cin-idx tmp-reg flag-reg flag-idx
                        red-tmp-reg))))

(define (mod-mul-litinski! c a-reg b-reg out-reg n+1 p
                           cin-reg cin-idx tmp-reg flag-reg flag-idx
                           red-tmp-reg)
  "Original Litinski wide-schoolbook + per-bit Solinas reduce. Renamed
   from mod-mul! so we can preserve the original code path for
   regression testing while mod-mul! itself becomes the dispatcher."
  (let ((n (- n+1 1)))
    (cond
      ((= n 0) #t)   ; degenerate, nothing to do
      (else
       ;; ── Stage 0: alloc Litinski scratch ──
       (alloc! c (quote sb-tmp-ext) (* 2 n))
       (alloc! c (quote sb-low) 1)
       (alloc! c (quote sb-xext) (+ n 1))
       (alloc! c (quote sb-const-tmp) (+ n 1))
       ;; ── Stage 1: compute wide product sb-tmp-ext := a * b ──
       (schoolbook-mul-into-addsub! c a-reg b-reg n
                                    (quote sb-low) 0
                                    (quote sb-tmp-ext)
                                    (quote sb-xext)
                                    cin-reg cin-idx
                                    (quote sb-const-tmp))
       ;; ── Stage 2: reduce sb-tmp-ext mod p into out ──
       ;; For each bit k in [0, 2n): if sb-tmp-ext[k]=1 then
       ;;   out += (2^k mod p) mod p.
       ;; Reversible via cload-const + mod-add + cunload-const, where the
       ;; constant lives in red-tmp-reg (n+1 wide, top bit |0>).
       (let loop ((k 0))
         (when (< k (* 2 n))
           (let ((c-k (modulo (expt 2 k) p)))
             (when (> c-k 0)   ; skip no-op constants
               ;; Load c-k into red-tmp controlled on sb-tmp-ext[k].
               (cload-const! c (quote sb-tmp-ext) k red-tmp-reg n+1 c-k)
               ;; Add red-tmp into out mod p.
               (mod-add!     c red-tmp-reg out-reg n+1 p
                             cin-reg cin-idx tmp-reg flag-reg flag-idx)
               ;; Unload c-k.
               (cunload-const! c (quote sb-tmp-ext) k red-tmp-reg n+1 c-k)))
           (loop (+ k 1))))
       ;; ── Stage 3: uncompute sb-tmp-ext back to |0> ──
       (schoolbook-mul-into-addsub-inverse! c a-reg b-reg n
                                            (quote sb-low) 0
                                            (quote sb-tmp-ext)
                                            (quote sb-xext)
                                            cin-reg cin-idx
                                            (quote sb-const-tmp))
       ;; ── Stage 4: free Litinski scratch ──
       (free! c (quote sb-const-tmp))
       (free! c (quote sb-xext))
       (free! c (quote sb-low))
       (free! c (quote sb-tmp-ext))))))

;;; ── mod-double-inplace! — v := 2v mod p, (n+1)-wide register ──
;;;
;;; Mirrors upstream's mod_double_inplace at mod.rs:2769.
;;;
;;; Pattern (cost: O(n) gates):
;;;   1. Shift-left v by 1 via SWAP cascade. Caller's (n+1)-wide v-reg
;;;      starts as [v_0 v_1 ... v_{n-1} 0]; after the cascade we have
;;;      [0 v_0 v_1 ... v_{n-1}]. Now v-reg = T = 2 * v_orig in [0, 2p).
;;;   2. Add c = 2^n - p across the full (n+1) bits. Sum S = T + c.
;;;      Top bit (idx n) of S is set iff T >= p.
;;;   3. flag := S[n] via CX.
;;;   4. csub c controlled on (NOT flag) — undoes the add when no reduction.
;;;   5. CX flag -> S[n] — clears the top bit when reduction needed.
;;;   6. Uncompute flag: T is even (= 2v), p is odd → after reduction v[0]=1;
;;;      no reduction → v[0]=0. So flag == v[0]. CX v[0] -> flag clears.
;;;
;;; All ancillae (cin, tmp, flag) return to |0>. v-reg top bit returns to |0>.
;;; Caller-supplied ancillae: cin (1 bit), tmp (n+1 wide), flag (1 bit).
;;;
;;; Variant choice: in-place via swap cascade + Solinas-style fold.
;;; Chosen because it mirrors upstream byte-for-byte; alternative
;;; Bennett-style "double via mod-add of copy" requires a 2^{-1} mod p
;;; classical inversion AND a fresh ancilla — heavier than this one
;;; ovf-bit pattern in lumbda. See task spec §"variant choice".
;;;
;;; SWAP not in our gate set — implemented as 3 CX (a→b, b→a, a→b).

(define (gate-swap! c a-reg a-idx b-reg b-idx)
  "SWAP qubit a with b via three CXs. Self-inverse."
  (gate-cx! c a-reg a-idx b-reg b-idx)
  (gate-cx! c b-reg b-idx a-reg a-idx)
  (gate-cx! c a-reg a-idx b-reg b-idx))

;;; ── pseudo-Mersenne mod-double (Schrottenloher 2026 Algorithm 7) ─
;;;
;;; For pseudo-Mersenne primes p = 2^u - f with f << 2^u (secp256k1: u=256,
;;; f=2^32+977=4294968273, 33 bits) the entire add-const / csub-const /
;;; flag-uncompute dance collapses to a single controlled add of f over the
;;; LOW lsbs bits of v, controlled on the carry-out from the shift.
;;;
;;; Algorithm 7 (qarton special_mod_arithmetic.py:54-92):
;;;   1. shift v left by 1 (anc receives MSB carry-out)
;;;   2. cadd(anc, f, v[:lsbs])   — controlled add of f into low lsbs bits
;;;   3. cx(v[0], anc)            — uncompute anc via parity
;;;
;;; Correctness lsbs = padding + bit_length(f). The cadd carry walks at most
;;; lsbs bits; if it would propagate further, the result is wrong. For
;;; uniform random v the failure probability is roughly 2^(-padding). Qarton
;;; uses padding=30 by default — same as Schrottenloher §4.
;;;
;;; Toffoli savings vs control: control mod-double-inplace! emits one
;;; add-const + one csub-const, both at full width (n+1). Each cuccaro-add
;;; over k bits costs 2(k-1) Toffoli (HEAD's HMR-borrowed variant: k-1).
;;; Pseudo-Mersenne emits ONE cadd-const at width lsbs only. Predicted
;;; Toffoli savings at secp256k1 width: ≈ 2 × (n+1 - lsbs) / (2(n+1)) ≈
;;; (256 - 63) / 257 ≈ 75 % of mod-double Toffoli; mod-double itself sits
;;; at ~8 % of total (Schrottenloher Table 3) → predicted 5-10 % full-stack.

(define *mod-double-use-pseudo-mersenne* #f)
;;; *mod-double-pseudo-mersenne-padding* — extra carry-safety bits beyond
;;; bit_length(f) for the controlled add. Larger padding → smaller flake
;;; probability ≈ 2^(-padding) but more Toffoli per call. Qarton + paper
;;; both use 30 by default.
(define *mod-double-pseudo-mersenne-padding* 30)

;;; *windowed-mod-double-r* — sweep-windowed-mod-double-r dispatcher.
;;; When #t, mod-double-inplace! routes through mod-double-inplace-
;;; windowed! (HEAD modular.rs:417-419 windowed branch). Foundation for
;;; K=5 apply-phase split — HEAD's compressed.rs:1986-1999 + 2515
;;; lean on the windowed form for the q1192 island. Default #f preserves
;;; byte-identity for every existing caller. Truncation flake
;;; probability ≈ 2^-(window+1) per call (window pulled from
;;; *windowed-mod-double-r-window*, default 8 matching HEAD).
;;;
;;; Composes with neither *mod-double-use-pseudo-mersenne* nor the
;;; alg-11 safe-band detector — the windowed path is its own dispatch
;;; branch (highest-priority) in mod-double-inplace!.
(define *windowed-mod-double-r* #f)
(define *windowed-mod-double-r-window* 8)

(define (pmersenne-bit-length n)
  "Number of bits to represent positive integer n (== Python's int.bit_length).
   bit-length(0)=0, bit-length(1)=1, bit-length(2)=2, bit-length(3)=2, ..."
  (let loop ((k 0) (m n))
    (if (= m 0) k (loop (+ k 1) (quotient m 2)))))

(define (mod-double-inplace-pseudo-mersenne!
         c v-reg n+1 p pmersenne-f
         cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "Pseudo-Mersenne variant of mod-double-inplace!. Same calling convention
   (v-reg (n+1) wide, cin/tmp/flag scratch); ignores flag-reg/flag-idx
   (kept for signature compatibility with the dispatcher).
   pmersenne-f = 2^n - p (must be > 0 and small)."
  (let* ((n      (- n+1 1))
         (f-bits (pmersenne-bit-length pmersenne-f))
         (padding *mod-double-pseudo-mersenne-padding*)
         (lsbs    (min n+1 (+ padding f-bits))))
    ;; (1) Shift-left v in place via SWAP cascade.
    ;;     End state: bit 0 = 0, bit i (i>=1) = v_orig[i-1],
    ;;                bit n = v_orig[n-1] = pseudo-Mersenne carry-out.
    (let loop ((i n))
      (when (> i 0)
        (gate-swap! c v-reg i v-reg (- i 1))
        (loop (- i 1))))
    ;; (2) cadd(anc=v[n], f, v[0..lsbs))  — controlled add of f into low bits.
    ;;     No aliasing concern: ctrl-idx = n, tgt-idx range = [0, lsbs) with
    ;;     lsbs < n+1, so ctrl bit never overlaps with cadd's target slice.
    (cadd-const! c v-reg lsbs pmersenne-f
                 v-reg n cin-reg cin-idx tmp-reg)
    ;; (3) Uncompute anc via parity: 2v is even, p is odd → after reduction
    ;;     v[0] = 1, no reduction → v[0] = 0. CX v[0] -> v[n] clears anc.
    (gate-cx! c v-reg 0 v-reg n)))

;;; ── mod-halve-inplace-direct-const-fast! ──────────────────────────
;;;
;;; Port of HEAD mod_halve_inplace_direct_const_fast
;;; (src/point_add/arith/modular.rs:753-765, commit 2dcf00d). Gate-level
;;; inverse of mod_double_inplace_direct_const_fast (sweep-030 PORTED
;;; in lumbda as mod-double-inplace-pseudo-mersenne!). Closes the open
;;; question sweep-030 RESULTS.md flagged + the mod-add-double-qb
;;; PORTED-WITH-GAP from sweep-mod-qb-adders.
;;;
;;; HEAD algorithm (5 steps):
;;;   1. alloc ovf qubit
;;;   2. cx(v[0], ovf)                       -- XOR LSB into ovf
;;;   3. csub_nbit_const_direct_fast(v, c, ovf) where c = 2^n - p
;;;   4. swap chain: for i in 0..n-1: swap(v[i], v[i+1])  (right rotate)
;;;   5. swap(v[n-1], ovf); free ovf          -- ovf bit lands at v[n-1]
;;;
;;; This is the EXACT gate-level inverse of the direct-const double
;;; (HEAD line 408+): the double's pre-shift swap-chain becomes the
;;; halve's post-shift swap-chain; the double's cadd becomes the
;;; halve's csub; the double's parity-uncompute becomes the halve's
;;; parity-cx-INTO-ovf at the start.
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; this primitive yet. mod-add-double-qb (sweep-mod-qb-adders) can
;;; route through this once a follow-on sweep adds the dispatcher
;;; flag (analog of HEAD's KAL_DIRECT_CONST_HALVE / direct_const_
;;; walks_enabled).
;;;
;;; Caller supplies the 'mod-halve-anc qubit + carries lane via cin/
;;; tmp/flag (HEAD allocs inline; lumbda style routes through args).

;;; ── mod-double-inplace-direct-const-fast! — sweep-sq-lowq-shift22 ──
;;;
;;; HEAD modular.rs:414. Mirror of mod-halve-inplace-direct-const-fast!
;;; with cadd direction. Uses cadd-nbit-const-direct-fast! (PORTED in
;;; sweep-cadd-csub-direct-fast) for the Solinas correction.

(define (mod-double-inplace-direct-const-fast!
         c v-reg n+1 p pmersenne-f
         cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "Port of HEAD mod_double_inplace_direct_const_fast (modular.rs:414).
   v-reg := 2*v mod p (in place). v-reg is (n+1)-wide; v in low n bits,
   v[n] = ovf at |0> on entry + restored on exit. pmersenne-f = 2^n - p."
  (let* ((n (- n+1 1))
         (c-const pmersenne-f))
    ;; (1) swap(v[n-1], v[n]).
    (gate-swap! c v-reg (- n 1) v-reg n)
    ;; (2) Right-rotate the n low bits via reverse swap chain.
    (let loop ((i (- n 2)))
      (when (>= i 0)
        (gate-swap! c v-reg i v-reg (+ i 1))
        (loop (- i 1))))
    ;; (3) cadd-nbit-const-direct-fast! ctrl=v[n] (ovf) into v[0..n].
    (cadd-nbit-const-direct-fast!
      c v-reg n c-const v-reg n tmp-reg (* 4 n+1))
    ;; (4) Parity CX: v[0] XOR into v[n] (clears ovf).
    (gate-cx! c v-reg 0 v-reg n)))

;;; ── mod-double-inplace-windowed! — sweep-windowed-mod-double-r ──
;;;
;;; Port of HEAD `mod_double_inplace_fast_with_dirty`
;;; (modular.rs:398-444), windowed branch (lines 417-419 — fires when
;;; `double_carry_trunc_window()` returns `Some(w)` i.e. env var
;;; `KAL_DOUBLE_CARRY_TRUNC_W=w`). HEAD's K=5 apply-phase ipmul +
;;; quotient bodies (compressed.rs:1986-1999 + 2515) lean on this
;;; windowed form for the q1192 island; the apply-phase callsite
;;; allocates an `ovf` qubit, swaps the top bit out, right-rotates the
;;; low n bits, then runs ONE truncated cadd against ctrl=ovf instead
;;; of the standard add-const + csub-const + flag-uncompute pair.
;;;
;;; Structural shape vs `mod-double-inplace-direct-const-fast!`:
;;;
;;;   • direct-const-fast emits a FULL-width `cadd-nbit-const-direct-fast!`
;;;     (no carry-tail truncation; exact for any v).
;;;   • windowed emits `cadd-nbit-const-direct-trunc-fast!` with carry
;;;     ripple stopped `window` bits past `highest_set_bit(c)`.
;;;     For secp256k1, c = 2^32 + 977 has highest-bit 32; window=8 stops
;;;     the ripple at bit 40 — saves ~(n - 40) carry maj-recurrence
;;;     CCXs + the matching backward HMR sweep per call. Per-call
;;;     Toffoli drops from ~2(n-1) to ~2*(highest_set_bit(c) + w).
;;;
;;; Flake probability: ~2^-(window+1) per call. At window=8 that's
;;; ~2^-9 ≈ 0.2 %. Production cells stack the apply-phase fold's same
;;; window so forward + reverse use matching truncation; mismatch only
;;; manifests when the carry-tail propagates through `window + 1`
;;; consecutive 1-bits in the running accumulator above bit 32 — the
;;; "exact-unless-rare-input" regime documented in HEAD's
;;; cadd_nbit_const_direct_trunc_fast docstring (const_arith.rs:526).
;;;
;;; Calling convention matches `mod-double-inplace!`:
;;;   v-reg : (n+1)-wide; v in low n bits, bit n at |0> in/out.
;;;   p     : prime; classical.
;;;   pmersenne-f : 2^n - p (HEAD's `c`). Caller computes once.
;;;   tmp-reg : (>= last+1)-wide ancilla at |0> for the carries lane.
;;;             `last = min(n-2, highest-set-bit(f) + window)`.
;;;
;;; Width assertion: caller must pass tmp-reg with capacity >= last+1.
;;; All existing dispatchers route mod-double-inplace! with tmp-reg
;;; sized n+1 — which is always >= last+1 since last <= n-2.

(define (mod-double-inplace-windowed!
         c v-reg n+1 p pmersenne-f
         cin-reg cin-idx tmp-reg flag-reg flag-idx window)
  "Port of HEAD mod_double_inplace_fast_with_dirty windowed branch
   (modular.rs:417-419). v-reg := 2*v mod p (in place) via shift-cascade
   + ONE truncated cadd. Saves ~(n - hi - window) carry-sweep CCXs per
   call vs the non-windowed direct-const path.

   v-reg : (n+1)-wide; v in low n bits, bit n at |0> in/out.
   pmersenne-f : 2^n - p (HEAD's `c`).
   window : carry-tail safety bits past highest_set_bit(pmersenne-f).
            HEAD's default 8 — flake prob ~2^-(window+1) per call.
   cin-reg/cin-idx + flag-reg/flag-idx kept for signature parity; the
   windowed path does NOT use them (no separate flag ancilla — ovf
   lives at v[n] post-shift)."
  (let* ((n (- n+1 1))
         (c-const pmersenne-f))
    ;; (1) swap(v[n-1], v[n]).
    (gate-swap! c v-reg (- n 1) v-reg n)
    ;; (2) Right-rotate the n low bits via reverse swap chain.
    (let loop ((i (- n 2)))
      (when (>= i 0)
        (gate-swap! c v-reg i v-reg (+ i 1))
        (loop (- i 1))))
    ;; (3) cadd-nbit-const-direct-trunc-fast! ctrl=v[n] (ovf) into v[0..n).
    ;;     Unique bit-base via cdtf-alloc-bit-base! so back-to-back calls
    ;;     in K=2 shift2=1 path don't collide on HMR slots.
    (cadd-nbit-const-direct-trunc-fast!
      c v-reg n c-const v-reg n tmp-reg window (cdtf-alloc-bit-base! n))
    ;; (4) Parity CX: v[0] XOR into v[n] (clears ovf).
    (gate-cx! c v-reg 0 v-reg n)))

(define (mod-halve-inplace-direct-const-fast!
         c v-reg n+1 p pmersenne-f
         cin-reg cin-idx tmp-reg flag-reg flag-idx)
  ;; v-reg := v / 2 mod p (in place). v-reg is (n+1)-wide; v in low n
  ;; bits, bit n at |0> on entry + restored to |0> on exit (the ovf
  ;; ancilla). pmersenne-f = 2^n - p (matches mod-double-inplace-
  ;; pseudo-mersenne! caller convention). flag-reg/flag-idx kept for
  ;; signature symmetry with the dispatcher.
  (let* ((n (- n+1 1))
         (c-const pmersenne-f))   ; c = 2^n - p; HEAD line 757 same form
    ;; (1) Parity CX: v[0] XOR into v[n] (our ovf is at v[n]).
    (gate-cx! c v-reg 0 v-reg n)
    ;; (2) Controlled sub of c, ctrl = v[n] (= ovf).
    ;;     csub-nbit-const-direct-trunc-fast! with window = n is
    ;;     effectively non-truncated (no carry-tail truncation).
    (csub-nbit-const-direct-trunc-fast!
      c v-reg n c-const v-reg n tmp-reg n (* 4 n+1))
    ;; (3) Right-rotate the n low bits via swap chain. Matches HEAD's
    ;;     for i in 0..n-1: swap(v[i], v[i+1]).
    (let loop ((i 0))
      (when (< i (- n 1))
        (gate-swap! c v-reg i v-reg (+ i 1))
        (loop (+ i 1))))
    ;; (4) Final swap: v[n-1] <-> ovf (v[n]). ovf-content lands at
    ;;     v[n-1]; v[n] returns to |0> (the bit that came from v[n-1]
    ;;     after step 3's chain).
    (gate-swap! c v-reg (- n 1) v-reg n)))

(define (mod-double-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "v-reg := 2 * v-reg mod p (in place). v-reg is (n+1)-wide; v stored in
   low n bits, bit n starts |0> and ends |0>. cin/tmp/flag are the same
   scratch suite used by mod-add!: cin (1), tmp (n+1), flag (1), all |0>
   in/out. Cost: 1 cuccaro-add (the inner add-const) + 1 cuccaro-sub
   (csub-const) + 5n + O(1) Clifford gates. O(n) total.

   When *mod-double-use-pseudo-mersenne* is #t AND p is a pseudo-Mersenne
   prime (f = 2^n - p small), dispatches to mod-double-inplace-pseudo-mersenne!."
  (let* ((n      (- n+1 1))
         (c-const (- (expt 2 n) p))
         (f-bits  (pmersenne-bit-length c-const))
         (padding *mod-double-pseudo-mersenne-padding*))
    (cond
      ;; sweep-windowed-mod-double-r: HEAD modular.rs:417-419 windowed
      ;; branch. Routes through mod-double-inplace-windowed! (one
      ;; truncated cadd; no separate flag-ancilla / csub pair). Highest
      ;; priority — composes with neither the pseudo-Mersenne path nor
      ;; alg-11 safe-band. Default OFF for byte-identity.
      ((and *windowed-mod-double-r* (> c-const 0))
       (mod-double-inplace-windowed!
         c v-reg n+1 p c-const cin-reg cin-idx tmp-reg
         flag-reg flag-idx *windowed-mod-double-r-window*))
      ;; Dispatch to pseudo-Mersenne when flag on AND f is small enough
      ;; that lsbs = padding + f-bits stays strictly below n+1 (otherwise
      ;; the no-aliasing assumption breaks).
      ;;
      ;; 2026-06-12 — DISABLED pseudo-Mersenne. Same bug class as
      ;; mod-add-inplace-pseudo-mersenne! (commit 5e6e3af). Reducer
      ;; tests/sweep-doctrine/test-mod-double-top-bit-clean.lsp at
      ;; n+1=8, p=125 (non-Mersenne, bug range non-empty): v=63 →
      ;; got 126, expected 1. ARITH-FAIL with top bit clean (worse
      ;; than mod-add — silent wrong-output, no leak diagnostic).
      ;;
      ;; Root cause: step 1's shift-left captures v[n] = v_orig[n-1]
      ;; as the overflow indicator. This only fires when 2v ≥ 2^n,
      ;; not when 2v ≥ p. For v_orig ∈ [p/2, 2^(n-1)) where 2v ∈ [p,
      ;; 2^n), the algorithm doesn't reduce and step 3's parity-CX
      ;; doesn't fix it (v[0]=0 since 2v is even, no XOR).
      ;;
      ;; Standard mod-double-inplace! (else branch) uses full csub-
      ;; const-based reduction, provably correct, drop-in replacement.
      ;; Trade-off: more Toffolis but algorithmically sound.
      ;;
      ;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on,
      ;; mod-double-alg-11-safe? classically peeks v-reg & routes
      ;; pseudo-Mersenne only when 2v < p OR 2v >= 2^n (the safe regimes
      ;; outside the [p, 2^n) bug band).
      ((and *mod-double-use-pseudo-mersenne*
            (> c-const 0)
            (< (+ padding f-bits) n+1)
            (mod-double-alg-11-safe? c v-reg n+1 p))
       (mod-double-inplace-pseudo-mersenne!
         c v-reg n+1 p c-const cin-reg cin-idx tmp-reg flag-reg flag-idx))
      (else
       ;; (1) Shift-left v in place via SWAP cascade.
       ;;     End state: bit 0 = 0, bit i (i>=1) = v_orig[i-1], bit n = v_orig[n-1].
       ;;     Walk from top down: swap(v[n], v[n-1]), swap(v[n-1], v[n-2]), ...
       (let loop ((i n))
         (when (> i 0)
           (gate-swap! c v-reg i v-reg (- i 1))
           (loop (- i 1))))
       ;; (2) Add c = 2^n - p at width n+1.
       (add-const! c v-reg n+1 c-const cin-reg cin-idx tmp-reg)
       ;; (3) flag := v[n]
       (gate-cx!   c v-reg n flag-reg flag-idx)
       ;; (4) X flag so flag=1 when NO reduction needed; csub-const controlled.
       (gate-x!    c flag-reg flag-idx)
       (csub-const! c v-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg)
       (gate-x!    c flag-reg flag-idx)
       ;; (5) CX flag -> v[n] (clears top bit when reduction happened)
       (gate-cx!   c flag-reg flag-idx v-reg n)
       ;; (6) Uncompute flag via parity: flag == v[0]
       (gate-cx!   c v-reg 0 flag-reg flag-idx)))))

;;; ── mod-4x-inplace! — v := 4v mod p, sweep-apply-fused-fold sibling ─
;;;
;;; HEAD reference: `compressed.rs:2149-2281` `dialog_gcd_fused_double_y`.
;;; Lumbda hooks: STEP 7+8 dispatch under K=2 + apply-fused-fold flags
;;; at `mod-inv-by-dialog-gcd-host.lsp` ~line 345.
;;;
;;; Semantics: v := 4v mod p on a SINGLE shared carry chain (target).
;;; v-reg is (n+1)-wide; v stored in low n bits, bit n |0> in/out.
;;; cin/tmp/flag scratch reused across both folds (no extra ancilla
;;; vs `mod-double-inplace!` × 2). Classical-specialization at the
;;; caller — this primitive ships only when the classical Kaliski
;;; trace says shift2-bit = 1 for this iter; otherwise the caller
;;; emits one `mod-double-inplace!`.
;;;
;;; V1 (prior): sequential two-fold via two `mod-double-inplace-pseudo-
;;; mersenne!` calls — substrate vehicle but byte-identical to inline
;;; K=2 pattern. Shipped 2.0228e+10 at i258 (non-K2body).
;;;
;;; V2 (this commit): inlined dual-shift + explicit ovf1/ovf2 ancilla
;;; capture + two cadd-const calls sharing the cin/tmp carry buffer.
;;; Matches HEAD's STRUCTURAL layout (compressed.rs:2149-2281) — ovf1
;;; held in a side ancilla across shift2; ovf2 captured post-shift2;
;;; one cadd-const(f, ctrl=ovf1) + one cadd-const(2f, ctrl=ovf2) at
;;; width lsbs+1. Parity uncompute of ovf1/ovf2 from v[0]/v[1] post-fold.
;;;
;;; V2 buys substrate clarity, not Toffoli: the two carry sweeps remain
;;; physically distinct (lumbda lacks a per-position-controls cadd
;;; helper). Per-iter Toffoli ≈ V1 (≤ ±2 from extra ovf-uncompute CCX).
;;; Production score targets a small change vs V1 baseline; the true
;;; -8k..-16k Toff/shot saving rides on V2.5 — a new
;;; `cadd-2-controls-trunc-fast!` primitive that emits HEAD's 12-position
;;; controlled-add (compressed.rs:2193-2215) at width lsbs. V2 substrate
;;; positions ovf1/ovf2 in named ancilla so V2.5 lands as a single
;;; cadd-call replacement.
;;;
;;; Algorithm trace (n=256, secp256k1, c = 2^256 - p):
;;;   1. alloc ovf1 ancilla.
;;;   2. shift1 (swap cascade): v[n] := v_orig[n-1], v[0] := 0.
;;;   3. swap(v[n], ovf1): ovf1 := v_orig[n-1], v[n] := 0.
;;;   4. alloc ovf2 ancilla.
;;;   5. shift2 (swap cascade): v[n] := v_orig[n-2], v[0] := 0.
;;;      (Note v[0] entering shift2 was 0 post step 3; so v[0]=0 post.)
;;;   6. swap(v[n], ovf2): ovf2 := v_orig[n-2], v[n] := 0.
;;;   7. cadd-const(v, lsbs, f, ctrl=ovf1, cin/tmp): v += f · ovf1.
;;;   8. cadd-const(v, lsbs, 2f, ctrl=ovf2, cin/tmp): v += 2f · ovf2.
;;;      Same width as #7; padding leaves plenty of carry headroom
;;;      inside lsbs even though 2f has 1 more bit than f.
;;;   9. Parity uncompute ovf1: post-fold v[0] = ovf1 (f bit 0 = 1, 2f
;;;      bit 0 = 0 → v[0] = ovf1·1 + ovf2·0 = ovf1). CX v[0] → ovf1.
;;;  10. Parity uncompute ovf2: post-fold v[1] = ovf1·f[1] + ovf2·(2f)[1]
;;;      mod 2 = ovf1·f[1] + ovf2·f[0] = ovf1·f[1] + ovf2. When f[1]=0
;;;      (secp256k1: f=2^32+977, f[1]=0), v[1] = ovf2. CX v[1] → ovf2.
;;;      For general f, when f[1]=1 we'd need an extra CX ovf1 → ovf2
;;;      to absorb the f[1]·ovf1 term. Guarded explicitly below.
;;;  11. free ovf2, ovf1.
;;;
;;; Safety: errors when classical *dgcd-k2-bounded-shift* off.

(define (mod-4x-inplace! c v-reg n+1 p
                          cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "v-reg := 4 * v-reg mod p (in place). v-reg is (n+1)-wide; v stored
   in low n bits, bit n starts |0> and ends |0>. Same scratch suite as
   mod-double-inplace!.

   When *mod-double-use-pseudo-mersenne* is #t AND p is a pseudo-Mersenne
   prime (f = 2^n - p small), uses the V2 inlined dual-shift +
   ovf-capture path with two cadd-const calls sharing cin/tmp. Otherwise
   falls back to two mod-double-inplace! calls (general Solinas path).

   Defensive guard: errors when *dgcd-k2-bounded-shift* is off, since
   the host dispatch only emits this primitive when classical K=2 trace
   says shift2-bit=1 — calling it standalone outside that flow is a
   contract violation (would multiply v by 4 with no matching
   shift2-on-v_w under the iter).

   v-reg must be a named register (symbol). Allocates two ancilla
   registers `_4x-ovf1` and `_4x-ovf2` (1 bit each) — distinct from
   caller-supplied scratch so no aliasing risk. Both return to |0>."
  (cond
    ((not *dgcd-k2-bounded-shift*)
     (error "mod-4x-inplace! requires *dgcd-k2-bounded-shift* #t"))
    (else
     (let* ((n      (- n+1 1))
            (c-const (- (expt 2 n) p))
            (f-bits  (pmersenne-bit-length c-const))
            (padding *mod-double-pseudo-mersenne-padding*)
            (lsbs    (min n+1 (+ padding f-bits))))
       (cond
         ;; ── V2: pseudo-Mersenne dual-shift + ovf-capture ──
         ;; Pseudo-Mersenne fast path when f small enough for lsbs < n+1
         ;; AND f[1] = 0 (so post-fold v[1] = ovf2 cleanly with no
         ;; cross-term f[1]·ovf1). For secp256k1 f = 2^32 + 977 with
         ;; bit 1 = 0; for small-width probe p=11 f=5 with bit 1 = 0; both
         ;; OK. For f[1]=1 primes we fall back to V1 path.
         ((and *mod-double-use-pseudo-mersenne*
               (> c-const 0)
               (< (+ padding f-bits) n+1)
               (not (bit-set? c-const 1)))
          (let ((ovf1 '_4x-ovf1)
                (ovf2 '_4x-ovf2))
            (alloc! c ovf1 1)
            (alloc! c ovf2 1)
            ;; (1) shift1 swap cascade — v[n] := v_orig[n-1], v[0] := 0.
            (let loop ((i n))
              (when (> i 0)
                (gate-swap! c v-reg i v-reg (- i 1))
                (loop (- i 1))))
            ;; (2) capture ovf1: swap(v[n], ovf1). v[n] := 0, ovf1 := v_orig[n-1].
            (gate-swap! c v-reg n ovf1 0)
            ;; (3) shift2 swap cascade — v[n] := v_orig[n-2], v[0] := 0
            ;;     (v[0] was 0 post step 1; remains 0 post step 3 since
            ;;     each swap pushes the existing v[i-1] up).
            (let loop ((i n))
              (when (> i 0)
                (gate-swap! c v-reg i v-reg (- i 1))
                (loop (- i 1))))
            ;; (4) capture ovf2: swap(v[n], ovf2). v[n] := 0, ovf2 := v_orig[n-2].
            (gate-swap! c v-reg n ovf2 0)
            ;; (5+6) V2.5 fused fold: v[0..lsbs) += f·ovf1 + 2f·ovf2 in
            ;;       ONE truncated carry sweep via per-position-controls
            ;;       primitive. Replaces V2's two sequential cadd-const!
            ;;       calls (which each emitted a full Solinas ripple).
            ;;       Derives 4 ancilla (h, xed, eord, n10) from ovf1/ovf2,
            ;;       issues 1 truncated ripple at width lsbs, uncomputes
            ;;       the ancilla. Net save ~58 Toff/call vs V2.
            ;;       Hardcoded for secp256k1 c = 2^32+977 table (HEAD
            ;;       compressed.rs:2196-2210). Pre-guard via lsbs check.
            (cond
              ((and (> lsbs (+ (highest-set-bit c-const) 2))
                    *cadd-direct-trunc-fast*)
               (cadd-2-controls-trunc-fast!
                 c v-reg lsbs
                 c-const       ovf1 0
                 (* 2 c-const) ovf2 0
                 tmp-reg
                 *cadd-direct-window*
                 (cdtf-alloc-bit-base! lsbs)))
              (else
               ;; Narrow lsbs (small-width probe) OR direct-trunc-fast
               ;; off: keep V2's two-cadd path as the correctness floor.
               (cadd-const! c v-reg lsbs c-const
                            ovf1 0 cin-reg cin-idx tmp-reg)
               (cadd-const! c v-reg lsbs (* 2 c-const)
                            ovf2 0 cin-reg cin-idx tmp-reg)))
            ;; (7) Uncompute ovf1 via parity from v[0] = ovf1.
            (gate-cx! c v-reg 0 ovf1 0)
            ;; (8) Uncompute ovf2 via parity from v[1] = ovf2 (guard above
            ;;     ensures f[1] = 0 so no f[1]·ovf1 cross term).
            (gate-cx! c v-reg 1 ovf2 0)
            (free! c ovf2)
            (free! c ovf1)))
         ;; Pseudo-Mersenne but f[1]=1 OR no headroom: fall back to V1
         ;; sequential pseudo-Mersenne folds (correct, no extra savings).
         ((and *mod-double-use-pseudo-mersenne*
               (> c-const 0)
               (< (+ padding f-bits) n+1))
          (mod-double-inplace-pseudo-mersenne!
            c v-reg n+1 p c-const cin-reg cin-idx tmp-reg flag-reg flag-idx)
          (mod-double-inplace-pseudo-mersenne!
            c v-reg n+1 p c-const cin-reg cin-idx tmp-reg flag-reg flag-idx))
         ;; General Solinas fallback: two mod-double-inplace! calls.
         (else
          (mod-double-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
          (mod-double-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)))))))

;;; ── csub-2-controls-trunc-fast! — gate-level inverse of cadd-2-controls-trunc-fast! ─
;;;
;;; Drop-in mirror of `cadd-2-controls-trunc-fast!` (lines 1224-1325) where
;;; the per-position-controls truncated ripple uses `csub-per-position-
;;; controls-trunc!` instead of `cadd-per-position-controls-trunc!`. Derives
;;; the same 4 ancilla controls (h, xed, eord, n10) and uncomputes them in
;;; the exact-reverse order. Used by `mod-4x-inverse-inplace!` to gate-level
;;; invert HEAD's secp256k1-class pseudo-Mersenne 4x fold.
;;;
;;; Toffoli budget: identical to `cadd-2-controls-trunc-fast!` since
;;; csub-per-position-controls-trunc! emits the same 3-CCX-per-bit borrow
;;; sweep + HMR uncompute as the add variant. The 4 derived-ancilla setup +
;;; teardown is bit-for-bit shared with the forward call.
;;;
;;; Safety: identical bit-pattern guards as the forward variant — k2 must
;;; equal 2·k1 mod 2^lsbs AND k1 must carry HEAD's table bits {0,4,6,7,8,9,hi}.
;;; Errors otherwise. Caller responsible for picking a fresh `bit-base`
;;; window that does not collide with concurrent uses of the classical-bit
;;; lane (forward `cadd-2-controls-trunc-fast!` consumes
;;; [bit-base, bit-base + last] during its HMR uncompute pass).

(define (csub-2-controls-trunc-fast!
         c acc-reg lsbs k1 ctrl1-reg ctrl1-idx k2 ctrl2-reg ctrl2-idx
         tmp-reg window bit-base)
  "acc[0..lsbs) -= (ctrl1 ? k1 : 0) + (ctrl2 ? k2 : 0) in ONE truncated
   borrow sweep with per-position-controls. Hardcoded for HEAD's
   secp256k1-class table where k2 == 2·k1 AND k1's bits sit at
   {0,4,6,7,8,9,hi}. Gate-level inverse of cadd-2-controls-trunc-fast!.
   *fold-freed-tail* routes through cadd-fold-ripple-freed-tail!
   with is-add=#f (HEAD compressed.rs:3440 — same primitive serves
   both add and sub fused folds)."
  (cond
    (*fold-freed-tail*
     (let* ((kk1 (modulo k1 (expt 2 lsbs)))
            (kk2 (modulo k2 (expt 2 lsbs))))
       (cond
         ((= lsbs 0) #t)
         ((and (= kk1 0) (= kk2 0)) #t)
         (else
          (let ((hi (highest-set-bit kk1)))
            (when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs))))
              (error "csub-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)"
                     k1 k2 lsbs))
            (when (not (and (bit-set? kk1 0) (bit-set? kk1 4)
                            (bit-set? kk1 6) (bit-set? kk1 7)
                            (bit-set? kk1 8) (bit-set? kk1 9)
                            (bit-set? kk1 hi)))
              (error "csub-2-controls-trunc-fast!: k1 missing required bits"
                     k1 hi))
            (when (<= lsbs (+ hi 1))
              (error "csub-2-controls-trunc-fast!: lsbs <= hi+1, no room"
                     lsbs hi))
            (let* ((last     (min (- lsbs 2) (+ (+ hi 1) window)))
                   (hi-delta (+ hi 1)))
              (when (<= last hi-delta)
                (error "csub-2-controls-trunc-fast!: *fold-freed-tail* needs last > hi+1"
                       last hi-delta))
              (cadd-fold-ripple-freed-tail!
                c acc-reg lsbs
                ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx
                last hi hi-delta #f bit-base)))))))
    (else
  (let* ((kk1 (modulo k1 (expt 2 lsbs)))
         (kk2 (modulo k2 (expt 2 lsbs))))
    (cond
      ((= lsbs 0) #t)
      ((and (= kk1 0) (= kk2 0)) #t)
      (else
       (let ((hi (highest-set-bit kk1)))
         (when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs))))
           (error "csub-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)"
                  k1 k2 lsbs))
         (when (not (and (bit-set? kk1 0)
                         (bit-set? kk1 4)
                         (bit-set? kk1 6)
                         (bit-set? kk1 7)
                         (bit-set? kk1 8)
                         (bit-set? kk1 9)
                         (bit-set? kk1 hi)))
           (error "csub-2-controls-trunc-fast!: k1 missing required bits"
                  k1 hi))
         (when (<= lsbs (+ hi 1))
           (error "csub-2-controls-trunc-fast!: lsbs <= hi+1, no room"
                  lsbs hi))
         ;; Derive 4 ancilla controls — identical to forward path.
         (let ((h    '_v25r-h)
               (xed  '_v25r-xed)
               (eord '_v25r-eord)
               (n10  '_v25r-n10))
           (alloc! c h    1)
           (alloc! c xed  1)
           (alloc! c eord 1)
           (alloc! c n10  1)
           ;; h = ctrl1 & ctrl2
           (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
           ;; xed = ctrl1 ⊕ ctrl2
           (gate-cx!  c ctrl1-reg ctrl1-idx xed 0)
           (gate-cx!  c ctrl2-reg ctrl2-idx xed 0)
           ;; eord = xed ⊕ h
           (gate-cx!  c xed 0 eord 0)
           (gate-cx!  c h   0 eord 0)
           ;; n10 = ctrl2 ⊕ h
           (gate-cx!  c ctrl2-reg ctrl2-idx n10 0)
           (gate-cx!  c h           0       n10 0)
           ;; Issue the truncated borrow sweep with HEAD's per-position table.
           (let* ((last     (min (- lsbs 2)
                                 (+ (+ hi 1) window)))
                  (controls (make-perpos-secp256k1-fold-controls
                              hi
                              (cons ctrl1-reg ctrl1-idx)
                              (cons ctrl2-reg ctrl2-idx)
                              (cons xed       0)
                              (cons eord      0)
                              (cons n10       0)
                              (cons h         0))))
             (csub-per-position-controls-trunc!
               c acc-reg lsbs controls last tmp-reg bit-base))
           ;; Uncompute derived ancilla in EXACT reverse — mirrors forward.
           (gate-cx!  c h           0       n10 0)
           (gate-cx!  c ctrl2-reg ctrl2-idx n10 0)
           (gate-cx!  c h   0 eord 0)
           (gate-cx!  c xed 0 eord 0)
           (gate-cx!  c ctrl2-reg ctrl2-idx xed 0)
           (gate-cx!  c ctrl1-reg ctrl1-idx xed 0)
           (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
           (free! c n10)
           (free! c eord)
           (free! c xed)
           (free! c h))))))))) ; closes (else ...) of *fold-freed-tail* dispatch

;;; ── mod-halve-inplace! — v := v * 2⁻¹ mod p, inverse of mod-double-inplace! ─
;;;
;;; Walk mod-double-inplace! steps in reverse with each step inverted.
;;; All 6 steps are self-inverse OR (add-const ↔ sub-const), (csub-const
;;; ↔ cadd-const). Used to walk hi back to its pre-Solinas state in
;;; Stage 2 of mod-mul-solinas!.

(define (mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "Inverse of mod-double-inplace!: v := v * (2⁻¹ mod p)."
  (let* ((n      (- n+1 1))
         (c-const (- (expt 2 n) p)))
    ;; (6') CX v[0] -> flag (self-inverse)
    (gate-cx!   c v-reg 0 flag-reg flag-idx)
    ;; (5') CX flag -> v[n] (self-inverse)
    (gate-cx!   c flag-reg flag-idx v-reg n)
    ;; (4') Reverse the X-csub-X sandwich. cadd-const replaces csub-const.
    (gate-x!    c flag-reg flag-idx)
    (cadd-const! c v-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg)
    (gate-x!    c flag-reg flag-idx)
    ;; (3') CX v[n] -> flag (self-inverse)
    (gate-cx!   c v-reg n flag-reg flag-idx)
    ;; (2') sub-const c at width n+1 (inverse of add-const)
    (sub-const! c v-reg n+1 c-const cin-reg cin-idx tmp-reg)
    ;; (1') Reverse the SWAP cascade. Walk from bottom up.
    (let loop ((i 1))
      (when (<= i n)
        (gate-swap! c v-reg i v-reg (- i 1))
        (loop (+ i 1))))))

;;; ── mod-4x-inverse-inplace! — v := v * 4⁻¹ mod p, gate-level inverse ─
;;;                                of mod-4x-inplace!
;;;
;;; HEAD reference: `compressed.rs:2283-2403` (`dialog_gcd_fused_halve_y`)
;;; — runs HEAD's apply-phase REVERSE pass during compressed-block
;;; decompression. Half of HEAD's headline -25k Toff/shot savings at
;;; iters=258 rides the reverse fold.
;;;
;;; Algorithm: walk `mod-4x-inplace!` (lines 3017-3122) in reverse with
;;; each step replaced by its gate-level inverse.
;;;
;;;   Forward (V2.5 pseudo-Mersenne path):
;;;     1. alloc ovf1, ovf2
;;;     2. shift1 cascade (swap down: bit i ↔ bit i-1, i = n..1)
;;;     3. swap(v[n], ovf1)
;;;     4. shift2 cascade (swap down)
;;;     5. swap(v[n], ovf2)
;;;     6. cadd-2-controls-trunc-fast! (+ f·ovf1 + 2f·ovf2 single ripple)
;;;        OR two cadd-const fallback (narrow-lsbs / direct-trunc-fast off)
;;;     7. cx v[0] → ovf1 (parity uncompute)
;;;     8. cx v[1] → ovf2 (parity uncompute)
;;;     9. free ovf2, ovf1
;;;
;;;   Reverse:
;;;     1. alloc ovf1, ovf2 (both |0>)
;;;     2'. cx v[1] → ovf2 (self-inverse — re-encode parity)
;;;     3'. cx v[0] → ovf1 (self-inverse — re-encode parity)
;;;     4'. csub-2-controls-trunc-fast! (inverse of 6 forward)
;;;          OR two csub-const fallback
;;;     5'. swap(v[n], ovf2) (self-inverse)
;;;     6'. shift2 cascade reversed (swap UP: bit i-1 ↔ bit i, i = 1..n)
;;;     7'. swap(v[n], ovf1) (self-inverse)
;;;     8'. shift1 cascade reversed (swap up)
;;;     9'. free ovf2, ovf1
;;;
;;; The shift cascades use `gate-swap!` which is self-inverse, so reversing
;;; the loop direction inverts the cascade.
;;;
;;; Each cadd ↔ csub pair has identical Toffoli budget — the reverse fold
;;; emits the SAME -58 Toff/call savings vs the V1 sequential `mod-halve`
;;; equivalent. ~50 % shift2-density × iters=258 ≈ 129 calls/shot →
;;; -7-8k Toff/shot when the reverse-fusion has a callsite. Combined
;;; with forward fusion: HEAD's headline -25k Toff/shot.
;;;
;;; CALLSITE NOTE: lumbda's `mod-inv-by-dialog-gcd-host!` backward sweep
;;; (line 595) runs CLASSICAL-REPLAY via `classical-reset!`, not a
;;; gate-level reverse iter walk. The reverse-fusion primitive ships now
;;; so a future sweep that adds a gate-level reverse iter (Option A,
;;; multi-day) has the apply-phase reverse-fold ready. See
;;; SWEEP-NOTES.md for the substrate gap analysis.
;;;
;;; Safety: identical guards to `mod-4x-inplace!`. Errors when
;;; *dgcd-k2-bounded-shift* off (semantics meaningless outside K=2 trace).

(define (mod-4x-inverse-inplace! c v-reg n+1 p
                                  cin-reg cin-idx tmp-reg flag-reg flag-idx)
  "v-reg := v-reg * (4⁻¹ mod p) (in place). v-reg is (n+1)-wide; v stored
   in low n bits, bit n starts |0> and ends |0>. Same scratch suite as
   mod-4x-inplace!.

   When *mod-double-use-pseudo-mersenne* is #t AND p is a pseudo-Mersenne
   prime AND f[1] = 0, walks the V2 inlined dual-shift + ovf-capture path
   in reverse using csub-const (or csub-2-controls-trunc-fast! when
   *cadd-direct-trunc-fast* on). Otherwise falls back to two
   mod-halve-inplace! calls (general Solinas path).

   Defensive guard: errors when *dgcd-k2-bounded-shift* is off."
  (cond
    ((not *dgcd-k2-bounded-shift*)
     (error "mod-4x-inverse-inplace! requires *dgcd-k2-bounded-shift* #t"))
    (else
     (let* ((n      (- n+1 1))
            (c-const (- (expt 2 n) p))
            (f-bits  (pmersenne-bit-length c-const))
            (padding *mod-double-pseudo-mersenne-padding*)
            (lsbs    (min n+1 (+ padding f-bits))))
       (cond
         ;; ── V2-reverse: pseudo-Mersenne dual-shift + ovf-capture inverse ──
         ((and *mod-double-use-pseudo-mersenne*
               (> c-const 0)
               (< (+ padding f-bits) n+1)
               (not (bit-set? c-const 1)))
          (let ((ovf1 '_4xr-ovf1)
                (ovf2 '_4xr-ovf2))
            (alloc! c ovf1 1)
            (alloc! c ovf2 1)
            ;; (8') CX v[1] -> ovf2 (self-inverse — re-encode ovf2 parity).
            (gate-cx! c v-reg 1 ovf2 0)
            ;; (7') CX v[0] -> ovf1 (self-inverse — re-encode ovf1 parity).
            (gate-cx! c v-reg 0 ovf1 0)
            ;; (5+6') Inverse fused fold: v[0..lsbs) -= f·ovf1 + 2f·ovf2.
            (cond
              ((and (> lsbs (+ (highest-set-bit c-const) 2))
                    *cadd-direct-trunc-fast*)
               ;; H7a peel-8 fix: cdtf-alloc-bit-base! gives this call a
               ;; fresh non-overlapping slot range, so the prior `(+ base
               ;; (* 8 n+1))` hand-offset to dodge forward/reverse HMR
               ;; collision is no longer required.
               (csub-2-controls-trunc-fast!
                 c v-reg lsbs
                 c-const       ovf1 0
                 (* 2 c-const) ovf2 0
                 tmp-reg
                 *cadd-direct-window*
                 (cdtf-alloc-bit-base! lsbs)))
              (else
               ;; Narrow lsbs OR direct-trunc-fast off: invert via two
               ;; csub-const calls in reverse order (matches V2 fallback
               ;; pair `cadd-const(c,ovf1)` + `cadd-const(2c,ovf2)`).
               (csub-const! c v-reg lsbs (* 2 c-const)
                            ovf2 0 cin-reg cin-idx tmp-reg)
               (csub-const! c v-reg lsbs c-const
                            ovf1 0 cin-reg cin-idx tmp-reg)))
            ;; (4') swap(v[n], ovf2) — self-inverse (re-injects v_orig[n-2]).
            (gate-swap! c v-reg n ovf2 0)
            ;; (3') Reverse shift2 swap cascade. Forward walked i = n..1
            ;;      with gate-swap(v[i], v[i-1]); reverse walks i = 1..n.
            (let loop ((i 1))
              (when (<= i n)
                (gate-swap! c v-reg i v-reg (- i 1))
                (loop (+ i 1))))
            ;; (2') swap(v[n], ovf1) — self-inverse (re-injects v_orig[n-1]).
            (gate-swap! c v-reg n ovf1 0)
            ;; (1') Reverse shift1 swap cascade.
            (let loop ((i 1))
              (when (<= i n)
                (gate-swap! c v-reg i v-reg (- i 1))
                (loop (+ i 1))))
            (free! c ovf2)
            (free! c ovf1)))
         ;; Pseudo-Mersenne but f[1]=1 OR no headroom: invert via V1
         ;; sequential pseudo-Mersenne halves (two mod-halve passes).
         ((and *mod-double-use-pseudo-mersenne*
               (> c-const 0)
               (< (+ padding f-bits) n+1))
          (mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
          (mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx))
         ;; General Solinas fallback: two mod-halve-inplace! calls.
         (else
          (mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
          (mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)))))))