;;; adder.lsp — Cuccaro ripple-carry reversible n-bit adder.
;;;
;;; Phase B step 1 of the lumbda-native point-add port.
;;;
;;; Ports the upstream Rust primitives from
;;;   ~/git/ecdsafail-challenge/src/point_add/mod.rs:1027..1181
;;;
;;;   MAJ(x, y, w):  (cx w y) (cx w x) (ccx x y w)
;;;   UMA(x, y, w):  (ccx x y w) (cx w x) (cx x y)
;;;
;;;   cuccaro-add!(a, acc, c-in):
;;;     n = (length a) = (length acc)
;;;     n=0 -> noop
;;;     n=1 -> (cx c-in acc[0]) (cx a[0] acc[0])
;;;     else:
;;;       Forward MAJ sweep:
;;;         maj(c-in, acc[0], a[0])
;;;         for i in 1..n-1: maj(a[i-1], acc[i], a[i])
;;;       Final sum bit:
;;;         cx a[n-2] acc[n-1]
;;;         cx a[n-1] acc[n-1]
;;;       Reverse UMA sweep:
;;;         for i in (n-2)..1: uma(a[i-1], acc[i], a[i])
;;;         uma(c-in, acc[0], a[0])
;;;
;;; Invariant: (cuccaro-add! a acc c-in) leaves
;;;   acc := (acc + a) mod 2^n
;;;   a   := a (unchanged)
;;;   c-in := 0 (uncomputed cleanly)
;;;
;;; Validation: see tests/unit/test-adder.lsp. We run the resulting
;;; circuit through sim.lsp at n in {4, 8, 16} and assert the output
;;; register equals the classical (a + b) mod 2^n.

(load "quantum/gates.lsp")

;;; ── MAJ + UMA primitives ───────────────────────────────────────

(define (maj! c x-reg x-idx y-reg y-idx w-reg w-idx)
  "MAJ(x, y, w): (cx w y) (cx w x) (ccx x y w)."
  (gate-cx!  c w-reg w-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 (uma! c x-reg x-idx y-reg y-idx w-reg w-idx)
  "UMA(x, y, w): (ccx x y w) (cx w x) (cx x 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 x-reg x-idx y-reg y-idx))

;;; ── mcx3_polar + ctrl_maj family ──────────────────────────────────
;;;
;;; Port of HEAD's 3-control X with per-control polarity
;;; (arith/adder.rs:1761) plus the four controlled MAJ/UMA wrappers
;;; (lines 1804-1825) that build on it.
;;;
;;; SCOPE: default path of mcx3_polar (explicit CCX uncompute of
;;; scratch). HEAD's env-gated Gidney measured-uncompute branch (toggled
;;; by `DIALOG_GCD_CTRL_LOWQ_MEASURED=1`) saves the coherent CCX at the
;;; cost of an HMR + classical CZ correction. Deferred to a follow-up
;;; sweep — would add lumbda flag `*mcx3-polar-measured-uncompute*`
;;; defaulting `#f` (matches HEAD's env-unset default).
;;;
;;; All four `ctrl-*!` wrappers use mcx3-polar with all-positive
;;; polarities (the only callers in HEAD). Polarity arguments are kept
;;; in mcx3-polar!'s signature for full HEAD-API parity.

(define (mcx3-polar! c c1-reg c1-idx p1 c2-reg c2-idx p2 c3-reg c3-idx p3
                     target-reg target-idx scratch-reg scratch-idx)
  "target ^= (c1==p1) & (c2==p2) & (c3==p3). p1/p2/p3 are scheme
   booleans (#t = positive control, #f = negative-via-X-wrap). scratch
   borrowed clean (|0> in/out). Default path emits ccx(c1,c2,scratch),
   ccx(scratch,c3,target), then explicit ccx(c1,c2,scratch) uncompute.
   HEAD's Gidney measured-uncompute branch (env-gated) deferred."
  ;; X-wrap negative controls (HEAD adder.rs:1772-1780)
  (cond ((not p1) (gate-x! c c1-reg c1-idx)))
  (cond ((not p2) (gate-x! c c2-reg c2-idx)))
  (cond ((not p3) (gate-x! c c3-reg c3-idx)))
  ;; Compute scratch = c1 & c2, then target ^= scratch & c3.
  (gate-ccx! c c1-reg c1-idx c2-reg c2-idx scratch-reg scratch-idx)
  (gate-ccx! c scratch-reg scratch-idx c3-reg c3-idx target-reg target-idx)
  ;; Default-path uncompute: re-emit the same CCX. (Gidney path would
  ;; use HMR + cz_if here — deferred.)
  (gate-ccx! c c1-reg c1-idx c2-reg c2-idx scratch-reg scratch-idx)
  ;; X-wrap reverse — restore controls to original polarity (HEAD lines
  ;; 1791-1800).
  (cond ((not p3) (gate-x! c c3-reg c3-idx)))
  (cond ((not p2) (gate-x! c c2-reg c2-idx)))
  (cond ((not p1) (gate-x! c c1-reg c1-idx))))

(define (ctrl-maj! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx w-reg w-idx
                   scratch-reg scratch-idx)
  "Controlled MAJ. When ctrl=|1>, computes maj(x, y, w) in place
   (matches the uncontrolled maj!); when ctrl=|0>, no-op. Mirror of
   HEAD's ctrl_maj (arith/adder.rs:1804)."
  (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx y-reg y-idx)
  (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx x-reg x-idx)
  (mcx3-polar! c ctrl-reg ctrl-idx #t x-reg x-idx #t y-reg y-idx #t
               w-reg w-idx scratch-reg scratch-idx))

(define (ctrl-uma! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx w-reg w-idx
                   scratch-reg scratch-idx)
  "Controlled UMA — inverse of ctrl-maj!. Mirror of HEAD's ctrl_uma
   (arith/adder.rs:1810)."
  (mcx3-polar! c ctrl-reg ctrl-idx #t x-reg x-idx #t y-reg y-idx #t
               w-reg w-idx scratch-reg scratch-idx)
  (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx x-reg x-idx)
  (gate-ccx! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx))

(define (ctrl-inv-maj! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx w-reg w-idx
                       scratch-reg scratch-idx)
  "Controlled INV-MAJ — alt inverse used in HEAD's clean-MAJ blocks.
   Mirror of HEAD's ctrl_inv_maj (arith/adder.rs:1816)."
  (mcx3-polar! c ctrl-reg ctrl-idx #t x-reg x-idx #t y-reg y-idx #t
               w-reg w-idx scratch-reg scratch-idx)
  (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx x-reg x-idx)
  (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx y-reg y-idx))

(define (ctrl-inv-uma! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx w-reg w-idx
                       scratch-reg scratch-idx)
  "Controlled INV-UMA. Mirror of HEAD's ctrl_inv_uma
   (arith/adder.rs:1822)."
  (gate-ccx! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx)
  (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx x-reg x-idx)
  (mcx3-polar! c ctrl-reg ctrl-idx #t x-reg x-idx #t y-reg y-idx #t
               w-reg w-idx scratch-reg scratch-idx))

;;; ── Cuccaro ripple-carry adder ─────────────────────────────────

(define (cuccaro-add! c a-reg acc-reg cin-reg cin-idx n)
  "Emit gates implementing acc := (acc + a) mod 2^n.
   Requires (= n (register-width a-reg) (register-width acc-reg)).
   cin-reg[cin-idx] starts |0>, ends |0>."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c cin-reg cin-idx acc-reg 0)
     (gate-cx! c a-reg   0       acc-reg 0))
    (else
     ;; Forward MAJ sweep
     (maj! c cin-reg cin-idx acc-reg 0 a-reg 0)
     (let loop ((i 1))
       (when (< i (- n 1))
         (maj! c a-reg (- i 1) acc-reg i a-reg i)
         (loop (+ i 1))))
     ;; Final sum bit
     (gate-cx! c a-reg (- n 2) acc-reg (- n 1))
     (gate-cx! c a-reg (- n 1) acc-reg (- n 1))
     ;; Reverse UMA sweep
     (let loop ((i (- n 2)))
       (when (>= i 1)
         (uma! c a-reg (- i 1) acc-reg i a-reg i)
         (loop (- i 1))))
     (uma! c cin-reg cin-idx acc-reg 0 a-reg 0))))

;;; ── HEAD fast variant: HMR-uncompute carries ─────────────────────
;;;
;;; Port of HEAD's `cuccaro_add_fast` (mod.rs:1042-1092) +
;;; `cuccaro_sub_fast` (mod.rs:1658-1707). Allocates explicit carry
;;; ancillas + replaces UMA-CCX backward uncompute with HMR + push-cond +
;;; CZ + pop-cond per bit. Saves (n-1) Toffoli per call (0-Toffoli
;;; backward sweep per HEAD's design).
;;;
;;; Caller responsibility: provide `carries-name` register pre-allocated
;;; to width n-1 + clean (|0>); + a `bit-base` integer for classical bit
;;; IDs. The function uses bit IDs bit-base .. bit-base+n-2.

(define (cuccaro-add-fast! c a-reg acc-reg cin-reg cin-idx n
                           carries-name bit-base)
  "Same algebra as cuccaro-add! but with HMR carry uncompute.
   Pre: carries-name register (width n-1) allocated by caller, all |0>.
   Post: carries-name returns to |0>; a-reg + cin-reg unchanged;
         acc-reg := (acc + a) mod 2^n.

   sweep-056: when (and *apply-phase-architecture* *cuccaro-vented*)
   is #t, dispatch into cuccaro-add-fast-vented!."
  (cond
    ((and *cuccaro-vented* *apply-phase-architecture*)
     (cuccaro-add-fast-vented! c a-reg acc-reg cin-reg cin-idx n
                               carries-name bit-base))
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c cin-reg cin-idx acc-reg 0)
     (gate-cx! c a-reg   0       acc-reg 0))
    (else
     ;; Forward sweep — MAJ-like with explicit carries
     (gate-cx!  c a-reg 0 acc-reg 0)
     (gate-cx!  c a-reg 0 cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-name 0)
     (gate-cx!  c carries-name 0 a-reg 0)
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (gate-cx!  c a-reg i acc-reg i)
         (gate-cx!  c a-reg i a-reg (- i 1))
         (gate-ccx! c a-reg (- i 1) acc-reg i carries-name i)
         (gate-cx!  c carries-name i a-reg i)
         (loop-fwd (+ i 1))))
     ;; Final sum bit
     (gate-cx! c a-reg (- n 2) acc-reg (- n 1))
     (gate-cx! c a-reg (- n 1) acc-reg (- n 1))
     ;; Backward HMR uncompute sweep (0 Toffoli)
     (let loop-back ((i (- n 2)))
       (when (>= i 1)
         (gate-cx!         c carries-name i a-reg i)
         (gate-hmr!        c carries-name i (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c a-reg (- i 1) acc-reg i)
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg i a-reg (- i 1))
         (gate-cx!         c a-reg (- i 1) acc-reg i)
         (loop-back (- i 1))))
     ;; Step 0 backward
     (gate-cx!         c carries-name 0 a-reg 0)
     (gate-hmr!        c carries-name 0 bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx acc-reg 0)
     (gate-pop-cond!   c)
     (gate-cx!         c a-reg 0 cin-reg cin-idx)
     (gate-cx!         c cin-reg cin-idx acc-reg 0))))

(define (cuccaro-sub-fast! c a-reg acc-reg cin-reg cin-idx n
                           carries-name bit-base)
  "Same as cuccaro-add-fast! but: acc := (acc - a - cin) mod 2^n.
   Mirrors HEAD's cuccaro_sub_fast (mod.rs:1658-1707).

   sweep-056: vented dispatch on (and *apply-phase-architecture*
   *cuccaro-vented*) #t."
  (cond
    ((and *cuccaro-vented* *apply-phase-architecture*)
     (cuccaro-sub-fast-vented! c a-reg acc-reg cin-reg cin-idx n
                               carries-name bit-base))
    ((= 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
     ;; Forward inv_UMA sweep
     (gate-cx!  c cin-reg cin-idx acc-reg 0)
     (gate-cx!  c a-reg 0 cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-name 0)
     (gate-cx!  c carries-name 0 a-reg 0)
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (gate-cx!  c a-reg (- i 1) acc-reg i)
         (gate-cx!  c a-reg i a-reg (- i 1))
         (gate-ccx! c a-reg (- i 1) acc-reg i carries-name i)
         (gate-cx!  c carries-name i a-reg i)
         (loop-fwd (+ i 1))))
     ;; Final sum bit
     (gate-cx! c a-reg (- n 1) acc-reg (- n 1))
     (gate-cx! c a-reg (- n 2) acc-reg (- n 1))
     ;; Backward inv_MAJ HMR uncompute sweep
     (let loop-back ((i (- n 2)))
       (when (>= i 1)
         (gate-cx!         c carries-name i a-reg i)
         (gate-hmr!        c carries-name i (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c a-reg (- i 1) acc-reg i)
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg i a-reg (- i 1))
         (gate-cx!         c a-reg i acc-reg i)
         (loop-back (- i 1))))
     ;; Step 0 backward
     (gate-cx!         c carries-name 0 a-reg 0)
     (gate-hmr!        c carries-name 0 bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx acc-reg 0)
     (gate-pop-cond!   c)
     (gate-cx!         c a-reg 0 cin-reg cin-idx)
     (gate-cx!         c a-reg 0 acc-reg 0))))

;;; *cuccaro-use-fast* — substrate flag. When #t, ctrl-cuccaro-*-hosted!
;;; (mod-inv-by-dialog-gcd-host.lsp) dispatches to cuccaro-{add,sub}-fast!
;;; instead of cuccaro-{add,sub}! for the inner ops. Caller must
;;; pre-allocate carries register + reserve bit-id range.

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

;;; *cuccaro-vented* — sweep-056 apply-phase retrofit flag.
;;;
;;; When BOTH *apply-phase-architecture* AND *cuccaro-vented* are #t,
;;; cuccaro-{add,sub}-fast! & cuccaro-{add,sub}-fast-borrowed! dispatch
;;; into apply-phase-aware vented variants (defined at end of this file).
;;; The vented variants exercise the sweep-054 substrate by wrapping each
;;; call in a begin-apply-phase! / end-apply-phase! scope pair & sourcing
;;; vent-key BitIds from apply-phase-bit-next (the substrate's global
;;; allocator at 1,000,000+) instead of the caller-supplied bit-base.
;;;
;;; Algorithmic note (per sweep-056 analysis): the legacy backward
;;; uncompute sweep already emits per-iter (hmr + push-cond + cz + pop-cond)
;;; which IS the venting wire pattern. Each iter's CZ_if acts on
;;; (a[i-1], acc[i]) — operand qubits that subsequent iters MUTATE via
;;; cx a[i] -> a[i-1] & cx a[i-1] -> acc[i] before sweep end. Deferring
;;; the CZ_if to a post-sweep broadcast would therefore use stale operand
;;; values & break correctness. The vented first-cut consequently keeps
;;; the per-iter wire pattern intact but routes vent-key allocation
;;; through the substrate — exercising begin/end scope discipline +
;;; bit-allocator state-machine. Downstream peak-qubits win requires
;;; restructuring the carries lane (HEAD venting.rs:147-309 ripples on 2
;;; clean ancillas instead of n-1) which exceeds the constraint of this
;;; sweep (adder.lsp-only, no caller surgery).
;;;
;;; When *apply-phase-architecture* is #f (default), this flag is inert
;;; even if set #t — the vented path checks the architecture flag first.

(define *cuccaro-vented* #f)

;;; ── HEAD borrowed-carries variant — overlay carries on caller's free ancilla ─
;;;
;;; Port of HEAD's `cuccaro_add_fast_borrowed_carries` (mod.rs:1097-1144) +
;;; `cuccaro_sub_fast_borrowed_carries` (mirror). Same gate sequence as the
;;; -fast! variant but the carries lane is BORROWED from a caller-supplied
;;; register at the given offset. The HMR uncompute returns carries to
;;; clean |0> so caller's register is unchanged at exit.
;;;
;;; HEAD comment line 1095: "Kaliski step4 can reuse clean high `tmp` lanes
;;; without increasing peak Q." Our equivalent: ctrl-cuccaro-*-hosted!
;;; passes mod-inv-by-dialog-gcd-host!'s tmp register as the carries source
;;; — tmp is free during STEP 4 (used only by mod-double-inplace! at STEP 7+8).

(define (cuccaro-add-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n
                                    carries-reg carries-offset bit-base)
  "Same as cuccaro-add-fast! but carries are borrowed from
   carries-reg starting at carries-offset (uses n-1 slots).
   carries-reg[carries-offset..carries-offset+n-2] must be |0>
   on entry; HMR uncompute returns them to |0> on exit.

   sweep-056: vented dispatch on (and *apply-phase-architecture*
   *cuccaro-vented*) #t."
  (cond
    ((and *cuccaro-vented* *apply-phase-architecture*)
     (cuccaro-add-fast-borrowed-vented! c a-reg acc-reg cin-reg cin-idx n
                                        carries-reg carries-offset bit-base))
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c cin-reg cin-idx acc-reg 0)
     (gate-cx! c a-reg   0       acc-reg 0))
    (else
     (gate-cx!  c a-reg 0 acc-reg 0)
     (gate-cx!  c a-reg 0 cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset a-reg 0)
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (gate-cx!  c a-reg i acc-reg i)
         (gate-cx!  c a-reg i a-reg (- i 1))
         (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i))
         (gate-cx!  c carries-reg (+ carries-offset i) a-reg i)
         (loop-fwd (+ i 1))))
     (gate-cx! c a-reg (- n 2) acc-reg (- n 1))
     (gate-cx! c a-reg (- n 1) acc-reg (- n 1))
     (let loop-back ((i (- n 2)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i) a-reg i)
         (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c a-reg (- i 1) acc-reg i)
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg i a-reg (- i 1))
         (gate-cx!         c a-reg (- i 1) acc-reg i)
         (loop-back (- i 1))))
     (gate-cx!         c carries-reg carries-offset a-reg 0)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx acc-reg 0)
     (gate-pop-cond!   c)
     (gate-cx!         c a-reg 0 cin-reg cin-idx)
     (gate-cx!         c cin-reg cin-idx acc-reg 0))))

(define (cuccaro-add-fast-borrowed-no-cin! c a-reg acc-reg n
                                            carries-reg carries-offset bit-base)
  "acc += a mod 2^n with c_in PROVEN |0> by the caller. Mirrors HEAD's
   cuccaro_add_fast_borrowed_carries_no_cin (arith/adder.rs:1184).
   Same algebra as cuccaro-add-fast-borrowed! with the c_in qubit folded
   out — saves the 4 cin-touching CX gates (2 forward, 2 reverse) and
   means the caller doesn't need to alloc a c_in ancilla at all.
   carries-reg[carries-offset..carries-offset+n-2] must be |0> on entry;
   HMR uncompute returns them to |0> on exit.

   Per HEAD's comment at adder.rs:1218-1228: the trailing reverse-step
   pattern `cz_if(c_in,acc[0],m0); cx(a[0],c_in); cx(c_in,acc[0])` of
   the c_in form collapses to a single `cz_if(a[0],acc[0],m0)` here
   because (1) `cx(carries[0],a[0])` just restored a[0] to the frozen
   c_in value so cz_if on a[0] == cz_if on c_in, and (2) the two
   trailing CXs reset c_in (now |0>) and then cx c_in into acc (no-op
   on |0>) — both drop out."
  (cond
    ((= n 0) #t)
    ((= n 1)
     ;; Pure XOR — no carry lane needed when c_in == 0.
     (gate-cx! c a-reg 0 acc-reg 0))
    (else
     ;; Step 0 forward (cin folded out — a[0] takes its place as the
     ;; ccx control after the seed cx).
     (gate-cx!  c a-reg 0 acc-reg 0)
     (gate-ccx! c a-reg 0 acc-reg 0 carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset a-reg 0)
     ;; Forward sweep [1..n-1) — unchanged from cuccaro-add-fast-borrowed!
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (gate-cx!  c a-reg i acc-reg i)
         (gate-cx!  c a-reg i a-reg (- i 1))
         (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i))
         (gate-cx!  c carries-reg (+ carries-offset i) a-reg i)
         (loop-fwd (+ i 1))))
     ;; Top sum — unchanged.
     (gate-cx! c a-reg (- n 2) acc-reg (- n 1))
     (gate-cx! c a-reg (- n 1) acc-reg (- n 1))
     ;; Backward HMR sweep [1..n-1) reverse — unchanged.
     (let loop-back ((i (- n 2)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i) a-reg i)
         (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c a-reg (- i 1) acc-reg i)
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg i a-reg (- i 1))
         (gate-cx!         c a-reg (- i 1) acc-reg i)
         (loop-back (- i 1))))
     ;; Step 0 reverse — c_in folded out: just unwind carry[0] + cz_if
     ;; on a[0] (a[0] still carries the c_in value at this point because
     ;; the immediately-preceding `cx(carries[0],a[0])` restored it).
     ;; No trailing `cx(a[0],c_in)` + `cx(c_in,acc[0])` pair — see
     ;; docstring.
     (gate-cx!         c carries-reg carries-offset a-reg 0)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c a-reg 0 acc-reg 0)
     (gate-pop-cond!   c))))

(define (cuccaro-sub-fast-borrowed-no-cin! c a-reg acc-reg n
                                            carries-reg carries-offset bit-base)
  "acc -= a mod 2^n with c_in PROVEN |0>. Mirrors HEAD's
   cuccaro_sub_fast_borrowed_carries_no_cin (arith/adder.rs:1241).
   Same algebra as cuccaro-sub-fast-borrowed! with c_in folded out by
   exactly the same pattern as the add direction; see
   cuccaro-add-fast-borrowed-no-cin! docstring for the algebra rationale."
  (cond
    ((= n 0) #t)
    ((= n 1)
     ;; Pure XOR (subtraction mod 2 == addition mod 2 for the single
     ;; bit case; c_in == 0 collapses the cin-fed CX away).
     (gate-cx! c a-reg 0 acc-reg 0))
    (else
     ;; Step 0 forward (cin folded out, a[0] takes its place).
     (gate-ccx! c a-reg 0 acc-reg 0 carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset a-reg 0)
     ;; Forward sweep [1..n-1) — unchanged from cuccaro-sub-fast-borrowed!
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (gate-cx!  c a-reg (- i 1) acc-reg i)
         (gate-cx!  c a-reg i a-reg (- i 1))
         (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i))
         (gate-cx!  c carries-reg (+ carries-offset i) a-reg i)
         (loop-fwd (+ i 1))))
     ;; Top sum.
     (gate-cx! c a-reg (- n 1) acc-reg (- n 1))
     (gate-cx! c a-reg (- n 2) acc-reg (- n 1))
     ;; Backward HMR sweep [1..n-1) reverse.
     (let loop-back ((i (- n 2)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i) a-reg i)
         (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c a-reg (- i 1) acc-reg i)
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg i a-reg (- i 1))
         (gate-cx!         c a-reg i acc-reg i)
         (loop-back (- i 1))))
     ;; Step 0 reverse — c_in folded out.
     (gate-cx!         c carries-reg carries-offset a-reg 0)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c a-reg 0 acc-reg 0)
     (gate-pop-cond!   c)
     ;; Final acc XOR with a[0] in the sub direction — preserved from
     ;; cuccaro-sub-fast-borrowed!'s sub-direction tail (the cin form
     ;; ended with `cx(a[0],acc[0])` after the cz_if + reset triple,
     ;; and the reset triple drops out per the no-cin algebra but the
     ;; standalone `cx(a[0],acc[0])` stays because sub's algebra
     ;; requires it independently of c_in folding).
     (gate-cx! c a-reg 0 acc-reg 0))))

(define (cuccaro-sub-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n
                                    carries-reg carries-offset bit-base)
  "Same as cuccaro-sub-fast! but carries borrowed from carries-reg.

   sweep-056: vented dispatch on (and *apply-phase-architecture*
   *cuccaro-vented*) #t."
  (cond
    ((and *cuccaro-vented* *apply-phase-architecture*)
     (cuccaro-sub-fast-borrowed-vented! c a-reg acc-reg cin-reg cin-idx n
                                        carries-reg carries-offset bit-base))
    ((= 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
     (gate-cx!  c cin-reg cin-idx acc-reg 0)
     (gate-cx!  c a-reg 0 cin-reg cin-idx)
     (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset a-reg 0)
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (gate-cx!  c a-reg (- i 1) acc-reg i)
         (gate-cx!  c a-reg i a-reg (- i 1))
         (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i))
         (gate-cx!  c carries-reg (+ carries-offset i) a-reg i)
         (loop-fwd (+ 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-back ((i (- n 2)))
       (when (>= i 1)
         (gate-cx!         c carries-reg (+ carries-offset i) a-reg i)
         (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c a-reg (- i 1) acc-reg i)
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg i a-reg (- i 1))
         (gate-cx!         c a-reg i acc-reg i)
         (loop-back (- i 1))))
     (gate-cx!         c carries-reg carries-offset a-reg 0)
     (gate-hmr!        c carries-reg carries-offset bit-base)
     (gate-push-cond!  c bit-base)
     (gate-cz!         c cin-reg cin-idx acc-reg 0)
     (gate-pop-cond!   c)
     (gate-cx!         c a-reg 0 cin-reg cin-idx)
     (gate-cx!         c a-reg 0 acc-reg 0))))

;;; *cuccaro-use-borrowed* — when #t, ctrl-cuccaro-*-hosted! uses the
;;; cuccaro-fast-borrowed variants with tmp-reg as the carries source.
;;; ZERO peak qubit cost (tmp is already allocated by caller).

(define *cuccaro-use-borrowed* #f)

;;; ── sweep-cuccaro-lane-vector — multi-source borrow primitive ──────
;;;
;;; Port of HEAD's `dialog_gcd_build_composite_scratch` lane vector
;;; (compressed.rs:362-435). HEAD's body-scratch borrow is a `Vec<QubitId>`
;;; collected from MULTIPLE source slices (future-carry, current-block
;;; compressed cells, u-high, v-high). When `DIALOG_GCD_BORROW_CURRENT_BLOCK`
;;; fires (compressed.rs:416-427), the current block's own compressed cells
;;; are folded into the lanes — a pure qubit relabel that shrinks the
;;; body-scratch deficit.
;;;
;;; Lumbda's existing `cuccaro-*-fast-borrowed!` accepts a SINGLE
;;; `(carries-reg, carries-offset)` source: carry slot `i` resolves to
;;; `(carries-reg, carries-offset + i)`. The lane-vector primitive
;;; widens that signature: carry slot `i` resolves through a list of
;;; `(reg offset width)` triples, walking lanes left-to-right.
;;;
;;; Backward compatibility: a lane vector of `((carries-reg carries-offset (- n 1)))`
;;; produces a BYTE-IDENTICAL gate sequence to the single-source variant
;;; (proven by construction — see `cuccaro-lane-resolve` below).
;;;
;;; Lane-vector format: a list of triples `(reg offset width)` where
;;;   - reg is a register name (symbol or string)
;;;   - offset is the starting bit index within reg
;;;   - width is the number of |0> carry slots this lane contributes
;;; Total width across lanes MUST be >= n-1. Each lane's slice
;;;   reg[offset..offset+width] MUST be |0> on entry; the HMR uncompute
;;;   restores all lanes to |0> on exit (each lane bit is HMR'd via
;;;   bit-base + global-carry-index, so HMR classical bit IDs stay
;;;   sequential exactly like the single-source variant).
;;;
;;; `cuccaro-lane-resolve` translates a global carry index `i` ∈ [0, n-1)
;;; to a `(reg . offset)` pair by walking lane-vec. Total Toffoli /
;;; Clifford / HMR-bit counts are IDENTICAL to single-source — only
;;; the qubit IDs the gates touch change.

(define (cuccaro-lane-resolve lane-vec global-i)
  "Walk lane-vec to find the (reg . offset) for global carry index
   global-i. Returns a pair (reg . offset). Errors if global-i exceeds
   total lane width."
  (let loop ((lanes lane-vec) (remaining global-i))
    (cond
      ((null? lanes)
       (error "cuccaro-lane-resolve: carry index out of lane-vec total width"))
      (else
       (let* ((lane  (car lanes))
              (l-reg (car lane))
              (l-off (car (cdr lane)))
              (l-w   (car (cdr (cdr lane)))))
         (cond
           ((< remaining l-w)
            (cons l-reg (+ l-off remaining)))
           (else
            (loop (cdr lanes) (- remaining l-w)))))))))

(define (cuccaro-lane-total-width lane-vec)
  "Sum widths across lane-vec."
  (let loop ((lanes lane-vec) (acc 0))
    (cond
      ((null? lanes) acc)
      (else
       (loop (cdr lanes) (+ acc (car (cdr (cdr (car lanes))))))))))

;; Sentinel: lane primitives loaded
(define *cuccaro-lane-vector-loaded* #t)

(define (cuccaro-add-fast-borrowed-lane! c a-reg acc-reg cin-reg cin-idx n
                                          lane-vec bit-base)
  "Multi-source variant of cuccaro-add-fast-borrowed!. Carries are
   borrowed from a lane vector (list of `(reg offset width)` triples)
   instead of a single (carries-reg, carries-offset) source. Total
   lane-width must be >= n-1.

   Each lane's slice reg[offset..offset+width] must be |0> on entry;
   HMR uncompute restores all to |0> on exit. Consumes n-1 HMR
   classical bit IDs (bit-base..bit-base+n-2), identical to the
   single-source variant.

   Backward compat: passing `((reg off (- n 1)))` produces a gate stream
   byte-identical to cuccaro-add-fast-borrowed! at (reg, off)."
  (when (< (cuccaro-lane-total-width lane-vec) (- n 1))
    (error "cuccaro-add-fast-borrowed-lane!: lane-vec total width < n-1"))
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c cin-reg cin-idx acc-reg 0)
     (gate-cx! c a-reg   0       acc-reg 0))
    (else
     ;; Step 0 forward — lane slot 0
     (let* ((slot0 (cuccaro-lane-resolve lane-vec 0))
            (s0-reg (car slot0))
            (s0-off (cdr slot0)))
       (gate-cx!  c a-reg 0 acc-reg 0)
       (gate-cx!  c a-reg 0 cin-reg cin-idx)
       (gate-ccx! c cin-reg cin-idx acc-reg 0 s0-reg s0-off)
       (gate-cx!  c s0-reg s0-off a-reg 0))
     ;; Forward sweep i in [1, n-1)
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (let* ((slot (cuccaro-lane-resolve lane-vec i))
                (s-reg (car slot))
                (s-off (cdr slot)))
           (gate-cx!  c a-reg i acc-reg i)
           (gate-cx!  c a-reg i a-reg (- i 1))
           (gate-ccx! c a-reg (- i 1) acc-reg i s-reg s-off)
           (gate-cx!  c s-reg s-off a-reg i))
         (loop-fwd (+ i 1))))
     ;; Top sum capture
     (gate-cx! c a-reg (- n 2) acc-reg (- n 1))
     (gate-cx! c a-reg (- n 1) acc-reg (- n 1))
     ;; Backward HMR uncompute sweep, n-1 iters
     (let loop-back ((i (- n 2)))
       (when (>= i 1)
         (let* ((slot (cuccaro-lane-resolve lane-vec i))
                (s-reg (car slot))
                (s-off (cdr slot)))
           (gate-cx!         c s-reg s-off a-reg i)
           (gate-hmr!        c s-reg s-off (+ bit-base i))
           (gate-push-cond!  c (+ bit-base i))
           (gate-cz!         c a-reg (- i 1) acc-reg i)
           (gate-pop-cond!   c)
           (gate-cx!         c a-reg i a-reg (- i 1))
           (gate-cx!         c a-reg (- i 1) acc-reg i))
         (loop-back (- i 1))))
     ;; Step 0 backward
     (let* ((slot0 (cuccaro-lane-resolve lane-vec 0))
            (s0-reg (car slot0))
            (s0-off (cdr slot0)))
       (gate-cx!         c s0-reg s0-off a-reg 0)
       (gate-hmr!        c s0-reg s0-off bit-base)
       (gate-push-cond!  c bit-base)
       (gate-cz!         c cin-reg cin-idx acc-reg 0)
       (gate-pop-cond!   c)
       (gate-cx!         c a-reg 0 cin-reg cin-idx)
       (gate-cx!         c cin-reg cin-idx acc-reg 0)))))

(define (cuccaro-sub-fast-borrowed-lane! c a-reg acc-reg cin-reg cin-idx n
                                          lane-vec bit-base)
  "Multi-source variant of cuccaro-sub-fast-borrowed!. Mirror of
   cuccaro-add-fast-borrowed-lane! with sub algebra. Same lane-vec
   conventions; same n-1 HMR bit IDs consumed."
  (when (< (cuccaro-lane-total-width lane-vec) (- n 1))
    (error "cuccaro-sub-fast-borrowed-lane!: lane-vec total width < n-1"))
  (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
     ;; Step 0 forward
     (let* ((slot0 (cuccaro-lane-resolve lane-vec 0))
            (s0-reg (car slot0))
            (s0-off (cdr slot0)))
       (gate-cx!  c cin-reg cin-idx acc-reg 0)
       (gate-cx!  c a-reg 0 cin-reg cin-idx)
       (gate-ccx! c cin-reg cin-idx acc-reg 0 s0-reg s0-off)
       (gate-cx!  c s0-reg s0-off a-reg 0))
     ;; Forward sweep
     (let loop-fwd ((i 1))
       (when (< i (- n 1))
         (let* ((slot (cuccaro-lane-resolve lane-vec i))
                (s-reg (car slot))
                (s-off (cdr slot)))
           (gate-cx!  c a-reg (- i 1) acc-reg i)
           (gate-cx!  c a-reg i a-reg (- i 1))
           (gate-ccx! c a-reg (- i 1) acc-reg i s-reg s-off)
           (gate-cx!  c s-reg s-off a-reg i))
         (loop-fwd (+ i 1))))
     ;; Top borrow capture
     (gate-cx! c a-reg (- n 1) acc-reg (- n 1))
     (gate-cx! c a-reg (- n 2) acc-reg (- n 1))
     ;; Backward HMR uncompute sweep
     (let loop-back ((i (- n 2)))
       (when (>= i 1)
         (let* ((slot (cuccaro-lane-resolve lane-vec i))
                (s-reg (car slot))
                (s-off (cdr slot)))
           (gate-cx!         c s-reg s-off a-reg i)
           (gate-hmr!        c s-reg s-off (+ bit-base i))
           (gate-push-cond!  c (+ bit-base i))
           (gate-cz!         c a-reg (- i 1) acc-reg i)
           (gate-pop-cond!   c)
           (gate-cx!         c a-reg i a-reg (- i 1))
           (gate-cx!         c a-reg i acc-reg i))
         (loop-back (- i 1))))
     ;; Step 0 backward
     (let* ((slot0 (cuccaro-lane-resolve lane-vec 0))
            (s0-reg (car slot0))
            (s0-off (cdr slot0)))
       (gate-cx!         c s0-reg s0-off a-reg 0)
       (gate-hmr!        c s0-reg s0-off bit-base)
       (gate-push-cond!  c bit-base)
       (gate-cz!         c cin-reg cin-idx acc-reg 0)
       (gate-pop-cond!   c)
       (gate-cx!         c a-reg 0 cin-reg cin-idx)
       (gate-cx!         c a-reg 0 acc-reg 0)))))

;;; *cuccaro-use-borrowed-lane* — when #t, ctrl-cuccaro-*-hosted! uses
;;; the lane-vector primitives instead of the single-source borrowed
;;; variants. The lane vector is supplied via *cuccaro-lane-vector-thunk*
;;; — a thunk evaluated at each callsite that returns the current
;;; lane vector (lets callers build per-iter / per-call lane vectors
;;; from currently-allocated borrow sources).
;;;
;;; Default `#f` keeps the single-source path active → byte-identity
;;; with champion preserved. When `#t` AND *cuccaro-use-borrowed* is
;;; also `#t` (so the borrowed path is selected), the lane-vector
;;; primitive fires; single-source callers degrade to a one-lane vec
;;; produced by the default thunk for byte-identity.

(define *cuccaro-use-borrowed-lane* #f)

;; Default thunk: builds a one-lane vector covering the entire single-
;; source (tmp-borrow) carries region. Caller sets this to a custom
;; thunk to inject multi-source lanes (e.g. tmp-borrow + block-k
;; compressed cells).
;;
;; Thunk signature: (lambda (n tmp-name) lane-vector) — receives the
;; adder width n and the legacy tmp-borrow register name; returns a
;; lane-vec list of (reg offset width) triples with total width >= n-1.
(define (cuccaro-lane-default-thunk n tmp-name)
  (list (list tmp-name 0 (- n 1))))

(define *cuccaro-lane-vector-thunk* cuccaro-lane-default-thunk)

;;; ── HEAD specialization: cuccaro-add when acc is |0> on entry ─────
;;;
;;; Port of HEAD's `mod_add_qq_fast_from_zero` first-add specialization
;;; (mod.rs:961-1038). When the accumulator is provably |0> on entry,
;;; (acc + a) mod 2^n simplifies to a; the full Cuccaro adder reduces
;;; to n CX-copies of a into acc. Saves n-1 CCX per call vs the n-1
;;; MAJs in cuccaro-add!, & matches HEAD's lines 970-972 verbatim.
;;;
;;; Caller responsibility: acc-reg MUST be |0> on entry across all n
;;; bits. cin-reg unused (mirrors HEAD: no carry-in concept when both
;;; addends start at zero — cin would just leak into acc[0] as a CX).
;;; Pre/post: a-reg unchanged; acc-reg := a on exit.
;;;
;;; cin-reg/cin-idx parameters retained for signature parity with
;;; cuccaro-add! so the call sites in mod-add-from-zero! / mod-mul-
;;; solinas-from-zero! stay uniform.

(define (cuccaro-add-from-zero! c a-reg acc-reg cin-reg cin-idx n)
  "acc := a (mod 2^n) when acc is |0> on entry. n CX-copies, 0 CCX.
   cin-reg/cin-idx ignored (HEAD's specialization has no carry-in slot)."
  (let loop ((i 0))
    (when (< i n)
      (gate-cx! c a-reg i acc-reg i)
      (loop (+ i 1)))))

;;; ── HEAD low-to-ext family: source width n, acc width n+1 ─────────
;;;
;;; Port of HEAD's `cuccaro_add_fast_low_to_ext` (mod.rs:1711-1750) +
;;; `cuccaro_sub_fast_low_to_ext` (mod.rs:1754-1793). Same algebra as
;;; the non-ext fast variants but the accumulator is one bit wider than
;;; the source — the top sum bit (carry-out) is written into acc[n]
;;; instead of being discarded.
;;;
;;; Per HEAD's design, carries lane is internally caller-supplied (we
;;; expose carries-name + bit-base so the offset-aware windowed wrapper
;;; can drive these from a parent scope). carries width MUST be n.
;;; HMR bit IDs consumed: n (indices bit-base..bit-base+n-1).
;;;
;;; a-off and acc-off are starting indices into a-reg and acc-reg
;;; respectively — pass 0 for the default standalone call; the
;;; windowed top-level passes lo for per-block dispatch.

;;; ── cuccaro-add-low-to-ext-clean! + cuccaro-sub-low-to-ext-clean! ──
;;;
;;; Port of HEAD cuccaro_add_low_to_ext_clean (adder.rs:208-238) +
;;; cuccaro_sub_low_to_ext_clean (adder.rs:240-271), commit 2dcf00d.
;;; "Clean" variants: full n-step MAJ forward + UMA backward sweep,
;;; NO HMR, NO carry-lane ancilla -- "safe inside emit_inverse blocks"
;;; per HEAD's docstring. Materializes the carry-out into
;;; acc-ext[n] (the extension bit) via CX after the forward sweep.
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; either primitive yet. Closes §1.1 ABSENT rows 7+8 (the last two
;;; ABSENT rows in §1.1 — the Cuccaro family now has full primitive
;;; coverage per HEAD-PARITY-COLLAB).
;;;
;;; Algorithm (HEAD lines 208-238):
;;;   1. maj(c_in, acc[0], a[0])
;;;   2. for i=1..n-1: maj(a[i-1], acc[i], a[i])
;;;   3. cx(a[n-1], acc[n])     -- carry-out into ext bit
;;;   4. for i=n-1..1: uma(a[i-1], acc[i], a[i])
;;;   5. uma(c_in, acc[0], a[0])
;;;
;;; a-reg + cin-reg preserved across the call (carry chain closes back
;;; to entry state); acc-ext-reg gets sum + carry-out. n=0 is a
;;; clean no-op except CX(c_in, acc[0]) per HEAD's degenerate path.
;;;
;;; Sub-clean uses inv-uma!/inv-maj! and reverses the sweep order;
;;; the CX(a[n-1], acc[n]) sits in the middle, self-inverse.

(define (cuccaro-add-low-to-ext-clean!
         c a-reg acc-ext-reg n cin-reg cin-idx)
  ;; acc-ext := (a + acc-ext + cin); a-reg width >= n;
  ;; acc-ext-reg width >= n+1. a + cin restored.
  (cond
    ((= n 0)
     (gate-cx! c cin-reg cin-idx acc-ext-reg 0))
    (else
     (maj! c cin-reg cin-idx acc-ext-reg 0 a-reg 0)
     (let loop ((i 1))
       (when (< i n)
         (maj! c a-reg (- i 1) acc-ext-reg i a-reg i)
         (loop (+ i 1))))
     (gate-cx! c a-reg (- n 1) acc-ext-reg n)
     (let loop-back ((i (- n 1)))
       (when (>= i 1)
         (uma! c a-reg (- i 1) acc-ext-reg i a-reg i)
         (loop-back (- i 1))))
     (uma! c cin-reg cin-idx acc-ext-reg 0 a-reg 0))))

(define (cuccaro-sub-low-to-ext-clean!
         c a-reg acc-ext-reg n cin-reg cin-idx)
  ;; acc-ext := (acc-ext - (a + cin)). Per HEAD lines 240-271: same
  ;; carry identity under the running ext bit; uses inv_uma + inv_maj.
  (cond
    ((= n 0)
     (gate-cx! c cin-reg cin-idx acc-ext-reg 0))
    (else
     (inv-uma! c cin-reg cin-idx acc-ext-reg 0 a-reg 0)
     (let loop ((i 1))
       (when (< i n)
         (inv-uma! c a-reg (- i 1) acc-ext-reg i a-reg i)
         (loop (+ i 1))))
     (gate-cx! c a-reg (- n 1) acc-ext-reg n)
     (let loop-back ((i (- n 1)))
       (when (>= i 1)
         (inv-maj! c a-reg (- i 1) acc-ext-reg i a-reg i)
         (loop-back (- i 1))))
     (inv-maj! c cin-reg cin-idx acc-ext-reg 0 a-reg 0))))

(define (cuccaro-add-fast-low-to-ext! c
                                       a-reg a-off
                                       acc-reg acc-off
                                       cin-reg cin-idx
                                       n
                                       carries-reg carries-offset
                                       bit-base)
  "acc-ext := (acc-ext + a + cin) mod 2^(n+1).
   a-reg slice : a-reg[a-off..a-off+n] (source, width n)
   acc-reg slice: acc-reg[acc-off..acc-off+n+1] (extended, width n+1)
   Top sum bit (carry-out) lands at acc-reg[acc-off+n].
   carries-reg[carries-offset..carries-offset+n-1] must be |0> entry/exit.
   Consumes n HMR classical bit IDs (bit-base..bit-base+n-1)."
  (cond
    ((= n 0)
     (gate-cx! c cin-reg cin-idx acc-reg acc-off))
    (else
     ;; Forward sweep — n carries (one per source bit)
     (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)
         (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))))
     ;; Top sum bit captured into the extended slot acc[n]
     (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off n))
     ;; Backward HMR uncompute sweep (n-1 iters)
     (let loop-back ((i (- n 1)))
       (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))))
     ;; Step 0 backward
     (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-fast-low-to-ext! c
                                       a-reg a-off
                                       acc-reg acc-off
                                       cin-reg cin-idx
                                       n
                                       carries-reg carries-offset
                                       bit-base)
  "acc-ext := (acc-ext - a - cin) mod 2^(n+1). Mirror of
   cuccaro-add-fast-low-to-ext! — carries-reg + bit-base usage identical.
   Consumes n HMR classical bit IDs."
  (cond
    ((= n 0)
     (gate-cx! c cin-reg cin-idx acc-reg acc-off))
    (else
     ;; Forward inv-UMA sweep
     (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)
         (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))))
     ;; Top borrow bit captured into the extended slot acc[n]
     (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off n))
     ;; Backward HMR uncompute sweep
     (let loop-back ((i (- n 1)))
       (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))))
     ;; Step 0 backward
     (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))))

;;; ── low-to-ext borrowed-carries c_in-folded-out variants ──────────
;;;
;;; Ports of HEAD's `cuccaro_{add,sub}_fast_low_to_ext_borrowed_carries_no_cin`
;;; (`src/point_add/arith/adder.rs:631` + `:680`, commit 2dcf00d). Same
;;; algebra as the c_in form (cuccaro-{add,sub}-fast-low-to-ext!) with
;;; the c_in qubit folded out — saves 1 c_in ancilla + 4 trailing/leading
;;; CX gates per call when the caller proves c_in == |0>.
;;;
;;; SCOPE: ports the DEFAULT path only (HEAD's `gate_suffix` from
;;; `square_selfhost_gate_suffix_carries(n)` defaults to 0 via env var
;;; `SQUARE_SELFHOST_GATE_SUFFIX_CARRIES`). With gate_suffix=0 the
;;; hybrid borrowed/clean-MAJ scheme degenerates to pure borrowed-carries
;;; (the `for i in borrowed..n` clean-MAJ loops are empty). Hybrid scheme
;;; (env-driven gate_suffix > 0; lowers peak qubit by gate_suffix at the
;;; cost of extra Toffoli) is a separate future port — would add a
;;; lumbda flag `*cuccaro-low-ext-gate-suffix-carries*` and the maj/
;;; uma-fed clean-MAJ block. Worth doing when a lumbda caller materializes
;;; that wants the peak-qubit tradeoff.

(define (cuccaro-add-fast-low-to-ext-borrowed-no-cin!
         c a-reg a-off acc-reg acc-off n
         carries-reg carries-offset bit-base)
  "acc[acc-off..acc-off+n+1) += a[a-off..a-off+n) mod 2^(n+1) with c_in
   PROVEN |0> by the caller. Mirror of HEAD's
   cuccaro_add_fast_low_to_ext_borrowed_carries_no_cin at gate_suffix=0
   (the default env path). acc top bit (carry-out) lands at
   acc[acc-off+n]. carries-reg[carries-offset..carries-offset+n-1] must
   be |0> on entry; HMR uncompute returns them to |0> on exit. Consumes
   n HMR classical bit IDs (bit-base..bit-base+n-1)."
  (cond
    ((= n 0) #t)
    (else
     ;; Step 0 forward (cin folded out — a[0] takes its place).
     (gate-cx!  c a-reg a-off acc-reg acc-off)
     (gate-ccx! c a-reg a-off acc-reg acc-off carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset a-reg a-off)
     ;; Forward sweep [1..n) — borrowed-carries path; clean-MAJ block
     ;; (HEAD's `for i in borrowed..n`) is empty under gate_suffix=0.
     (let loop-fwd ((i 1))
       (when (< i n)
         (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))))
     ;; Top sum lands at acc[n] — the low-to-ext extension.
     (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off n))
     ;; Backward HMR uncompute sweep [1..n) reverse — borrowed pattern.
     ;; HEAD's reverse clean-UMA block (`for i in (borrowed..n).rev`) is
     ;; empty under gate_suffix=0.
     (let loop-back ((i (- n 1)))
       (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))))
     ;; Step 0 reverse — c_in folded out. cz_if on a[0] (the preceding
     ;; cx(carries[0],a[0]) restored a[0] to c_in's frozen value). No
     ;; trailing cx pair (see cuccaro-add-fast-borrowed-no-cin! docstring
     ;; for the algebra rationale).
     (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 a-reg a-off acc-reg acc-off)
     (gate-pop-cond!   c))))

(define (cuccaro-sub-fast-low-to-ext-borrowed-no-cin!
         c a-reg a-off acc-reg acc-off n
         carries-reg carries-offset bit-base)
  "acc[acc-off..acc-off+n+1) -= a[a-off..a-off+n) mod 2^(n+1) with
   c_in PROVEN |0>. Mirror of HEAD's
   cuccaro_sub_fast_low_to_ext_borrowed_carries_no_cin at gate_suffix=0.
   See add variant docstring for the c_in folding algebra; sub retains
   its trailing cx(a[0], acc[0]) per HEAD's sub-direction tail (the cz_if
   pair drops out but the standalone XOR is independent of c_in)."
  (cond
    ((= n 0) #t)
    (else
     ;; Step 0 forward (cin folded out, sub direction has no seed CX).
     (gate-ccx! c a-reg a-off acc-reg acc-off carries-reg carries-offset)
     (gate-cx!  c carries-reg carries-offset a-reg a-off)
     ;; Forward sweep [1..n) — sub direction; clean-INV-UMA block empty
     ;; under gate_suffix=0.
     (let loop-fwd ((i 1))
       (when (< i n)
         (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))))
     ;; Top sum lands at acc[n].
     (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off n))
     ;; Backward HMR uncompute sweep [1..n) reverse — sub direction.
     ;; Clean-INV-MAJ block empty under gate_suffix=0.
     (let loop-back ((i (- n 1)))
       (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))))
     ;; Step 0 reverse — c_in folded out.
     (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 a-reg a-off acc-reg acc-off)
     (gate-pop-cond!   c)
     ;; Trailing cx(a[0], acc[0]) — sub-direction algebra requires this
     ;; independently of c_in folding (only the cz_if + reset triple
     ;; collapses; standalone CX stays).
     (gate-cx! c a-reg a-off acc-reg acc-off))))

;;; ── Per-block kernel for windowed wrappers ────────────────────────
;;;
;;; cuccaro-add-fast-blk! / cuccaro-sub-fast-blk! — equal-width n add/sub
;;; with offset args plus top-bit overrides. Used by the windowed
;;; top-level for non-final blocks where the top bit of a is a fresh
;;; |0> ancilla (a-top-*) and the top bit of acc is a fresh cout
;;; ancilla (acc-top-*), each sitting in a separate register handle
;;; from the lo..hi-1 slice of the parent registers.
;;;
;;; Algebra mirrors `cuccaro_add_fast`(mod.rs:1042) but at every index
;;; i in [0,n), reads of `a[i]` and `acc[i]` resolve as:
;;;   if i < n-1: (parent-reg, parent-off + i)
;;;   if i = n-1: (top-reg,    top-idx)
;;;
;;; carries-reg width MUST be >= n-1 starting at carries-offset.
;;; Consumes (n-1) HMR classical bit IDs.

(define (cuccaro-add-fast-blk! c
                                a-reg a-off a-top-reg a-top-idx
                                acc-reg acc-off acc-top-reg acc-top-idx
                                cin-reg cin-idx
                                n
                                carries-reg carries-offset
                                bit-base)
  "Equal-width Cuccaro fast-add at width n with split top-bit operands.
   a[i<n-1]   = a-reg[a-off+i];     a[n-1]   = a-top-reg[a-top-idx]
   acc[i<n-1] = acc-reg[acc-off+i]; acc[n-1] = acc-top-reg[acc-top-idx]
   Consumes (n-1) HMR classical bit IDs (bit-base..bit-base+n-2)."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c cin-reg     cin-idx     acc-top-reg acc-top-idx)
     (gate-cx! c a-top-reg   a-top-idx   acc-top-reg acc-top-idx))
    (else
     ;; helpers: resolve "bit i of a" and "bit i of acc" via inline cond
     ;; (no values/multi-return needed — just emit the call directly)
     ;;
     ;; Forward sweep
     ;; Step 0
     (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)
     ;; Steps i in [1, n-1) — pure parent-slice case
     (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))))
     ;; Final sum bit: two CXs into acc[n-1] = acc-top
     ;;   cx(a[n-2], acc[n-1])  cx(a[n-1], acc[n-1])
     (gate-cx! c a-reg     (+ a-off (- n 2)) acc-top-reg acc-top-idx)
     (gate-cx! c a-top-reg a-top-idx         acc-top-reg acc-top-idx)
     ;; Backward HMR uncompute (i in (n-2)..1, descending)
     ;; NOTE: backward loop in cuccaro_add_fast runs i in 1..n-1 reversed
     ;; → i = n-2 down to 1. All such i satisfy i < n-1, so a[i],a[i-1]
     ;; both live in the parent slice. acc[i] also lives in parent slice.
     (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))))
     ;; Step 0 backward — uses cin + acc[0]
     (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-fast-blk! c
                                a-reg a-off a-top-reg a-top-idx
                                acc-reg acc-off acc-top-reg acc-top-idx
                                cin-reg cin-idx
                                n
                                carries-reg carries-offset
                                bit-base)
  "Equal-width Cuccaro fast-sub at width n with split top-bit operands.
   Top-bit override semantics identical to cuccaro-add-fast-blk!.
   Consumes (n-1) HMR classical bit IDs."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-cx! c a-top-reg a-top-idx acc-top-reg acc-top-idx)
     (gate-cx! c cin-reg   cin-idx   acc-top-reg acc-top-idx))
    (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))))
     ;; Final sub bit: two CXs into acc[n-1] = acc-top
     ;;   cx(a[n-1], acc[n-1])  cx(a[n-2], acc[n-1])
     (gate-cx! c a-top-reg a-top-idx         acc-top-reg acc-top-idx)
     (gate-cx! c a-reg     (+ a-off (- n 2)) acc-top-reg acc-top-idx)
     (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))))

;;; ── Windowed Cuccaro fast-add / fast-sub ──────────────────────────
;;;
;;; Port of HEAD's `cuccaro_add_fast_windowed` (mod.rs:1995-2055) +
;;; `cuccaro_sub_fast_windowed` (mod.rs:2061-2117).
;;;
;;; Threads the inter-block carry/borrow through a 1-bit extension per
;;; block. ~(n/blocks) measured-carry ancillae live at once (vs n-1 for
;;; a single cuccaro-add-fast!). ~1 Toffoli/bit; the MBUC saving is
;;; PEAK QUBITS — total Toffoli increases by O(blocks) due to per-block
;;; boundary-clear cmp_lt calls.
;;;
;;; Caller pre-allocates a `name-base` symbol scope; the windowed wrapper
;;; alloc's per-block ancillae using `(string->symbol (string-append
;;; (symbol->string name-base) "-blk-K-cout"))` and frees them in reverse.
;;;
;;; bit-base reservation: the caller MUST reserve at LEAST the following
;;; HMR bit IDs starting at bit-base:
;;;   - For each non-final block of width w_blk = hi-lo:
;;;       the per-block call uses (w_blk + 1) - 1 = w_blk HMR bits
;;;       (cuccaro-add-fast-blk! at n = w_blk + 1, consumes n-1 = w_blk)
;;;   - For the final block at width w_last (no extension):
;;;       cuccaro-add-fast! at n = w_last, consumes (n-1) = w_last-1 HMR
;;;   - For each non-final block's boundary clear:
;;;       cmp-lt-into-fast! at width p = hi, consumes p HMR bits
;;;
;;; Caller-side simplest upper bound: reserve 4n bit IDs starting at
;;; bit-base. We document tighter accounting per block below.

(define (cuccaro-add-fast-windowed! c
                                     a-reg acc-reg cin-reg cin-idx n
                                     blocks
                                     name-base bit-base)
  "acc := (acc + a + cin) mod 2^n via blocks-wise dispatch.
   blocks >= 1; clamped to [1, n]. blocks=1 falls back to
   cuccaro-add-fast! (uses a freshly-alloc'd carries register
   named (name-base)-carries-direct).
   See module header for bit-base reservation rules."
  (cond
    ((= n 0) #t)
    (else
     (let* ((blocks (cond ((< blocks 1) 1)
                          ((> blocks n) n)
                          (else blocks))))
       (cond
         ((= blocks 1)
          ;; Direct fallback: alloc carries (n-1) + delegate
          (let ((carries-name
                 (string->symbol
                  (string-append (symbol->string name-base)
                                 "-carries-direct"))))
            (alloc! c carries-name (- n 1))
            (cuccaro-add-fast! c a-reg acc-reg cin-reg cin-idx n
                               carries-name bit-base)
            (free! c carries-name)))
         (else
          ;; Walk blocks, threading carry. Track (cout-name, p) pairs.
          (let loop ((blk 0)
                     (lo 0)
                     (carry-reg cin-reg)
                     (carry-idx cin-idx)
                     (bit-cur bit-base)
                     (couts '()))
            (cond
              ((>= blk blocks)
               ;; Boundary clear pass over couts (reverse order).
               (windowed-clear-couts! c a-reg acc-reg
                                      couts
                                      name-base bit-cur
                                      'add)
               #t)
              (else
               (let* ((hi (quotient (* (+ blk 1) n) blocks)))
                 (cond
                   ((<= hi lo)
                    (loop (+ blk 1) lo carry-reg carry-idx bit-cur couts))
                   ((or (= blk (- blocks 1)) (= hi n))
                    ;; LAST block — non-extended cuccaro_add_fast at
                    ;; width (n - lo). Direct call into existing
                    ;; cuccaro-add-fast! which expects a-reg/acc-reg
                    ;; from index 0; we need an offset-aware variant.
                    ;; Use cuccaro-add-fast-blk! with a-top-* + acc-top-*
                    ;; pointing back into the parent at index (n-1).
                    (let* ((w (- n lo))
                           (carries-name
                            (string->symbol
                             (string-append (symbol->string name-base)
                                            "-carries-final"))))
                      (cond
                        ((= w 0) #t)
                        ((= w 1)
                         ;; Trivial 1-bit add at slot lo
                         (gate-cx! c carry-reg carry-idx acc-reg lo)
                         (gate-cx! c a-reg lo acc-reg lo))
                        (else
                         (alloc! c carries-name (- w 1))
                         (cuccaro-add-fast-blk!
                           c
                           a-reg lo
                           a-reg (+ lo (- w 1))      ; a-top = parent[n-1]
                           acc-reg lo
                           acc-reg (+ lo (- w 1))    ; acc-top = parent[n-1]
                           carry-reg carry-idx
                           w
                           carries-name 0
                           bit-cur)
                         (free! c carries-name)))
                      ;; final block — boundary clear over outstanding couts
                      (windowed-clear-couts! c a-reg acc-reg
                                             couts
                                             name-base
                                             (+ bit-cur (max 0 (- w 1)))
                                             'add)))
                   (else
                    ;; NON-final block — width w_blk = hi - lo, extended
                    ;; with fresh zero (above a slice) + cout (above acc
                    ;; slice). cuccaro-add-fast-blk! at n = w_blk + 1.
                    (let* ((w-blk    (- hi lo))
                           (n-ext    (+ w-blk 1))
                           (cout-name
                            (string->symbol
                             (string-append (symbol->string name-base)
                                            "-cout-"
                                            (number->string blk))))
                           (zero-name
                            (string->symbol
                             (string-append (symbol->string name-base)
                                            "-zero-"
                                            (number->string blk))))
                           (carries-name
                            (string->symbol
                             (string-append (symbol->string name-base)
                                            "-carries-"
                                            (number->string blk)))))
                      (alloc! c cout-name 1)
                      (alloc! c zero-name 1)
                      (alloc! c carries-name (- n-ext 1))
                      (cuccaro-add-fast-blk!
                        c
                        a-reg     lo
                        zero-name 0           ; a-top = fresh |0> ancilla
                        acc-reg   lo
                        cout-name 0           ; acc-top = cout ancilla
                        carry-reg carry-idx
                        n-ext
                        carries-name 0
                        bit-cur)
                      (free! c carries-name)
                      (free! c zero-name)
                      (loop (+ blk 1)
                            hi
                            cout-name 0
                            (+ bit-cur (- n-ext 1))
                            (cons (list cout-name hi) couts))))))))))))))
  #t)

(define (cuccaro-sub-fast-windowed! c
                                     a-reg acc-reg cin-reg cin-idx n
                                     blocks
                                     name-base bit-base)
  "acc := (acc - a - cin) mod 2^n via blocks-wise dispatch.
   Mirror of cuccaro-add-fast-windowed! using sub kernels.
   blocks=1 falls back to cuccaro-sub-fast!."
  (cond
    ((= n 0) #t)
    (else
     (let ((blocks (cond ((< blocks 1) 1)
                         ((> blocks n) n)
                         (else blocks))))
       (cond
         ((= blocks 1)
          (let ((carries-name
                 (string->symbol
                  (string-append (symbol->string name-base)
                                 "-carries-direct"))))
            (alloc! c carries-name (- n 1))
            (cuccaro-sub-fast! c a-reg acc-reg cin-reg cin-idx n
                               carries-name bit-base)
            (free! c carries-name)))
         (else
          (let loop ((blk 0)
                     (lo 0)
                     (borrow-reg cin-reg)
                     (borrow-idx cin-idx)
                     (bit-cur bit-base)
                     (bouts '()))
            (cond
              ((>= blk blocks)
               (windowed-clear-couts! c a-reg acc-reg
                                      bouts
                                      name-base bit-cur
                                      'sub)
               #t)
              (else
               (let* ((hi (quotient (* (+ blk 1) n) blocks)))
                 (cond
                   ((<= hi lo)
                    (loop (+ blk 1) lo borrow-reg borrow-idx bit-cur bouts))
                   ((or (= blk (- blocks 1)) (= hi n))
                    (let* ((w (- n lo))
                           (carries-name
                            (string->symbol
                             (string-append (symbol->string name-base)
                                            "-carries-final"))))
                      (cond
                        ((= w 0) #t)
                        ((= w 1)
                         (gate-cx! c a-reg lo acc-reg lo)
                         (gate-cx! c borrow-reg borrow-idx acc-reg lo))
                        (else
                         (alloc! c carries-name (- w 1))
                         (cuccaro-sub-fast-blk!
                           c
                           a-reg lo
                           a-reg (+ lo (- w 1))
                           acc-reg lo
                           acc-reg (+ lo (- w 1))
                           borrow-reg borrow-idx
                           w
                           carries-name 0
                           bit-cur)
                         (free! c carries-name)))
                      (windowed-clear-couts! c a-reg acc-reg
                                             bouts
                                             name-base
                                             (+ bit-cur (max 0 (- w 1)))
                                             'sub)))
                   (else
                    (let* ((w-blk    (- hi lo))
                           (n-ext    (+ w-blk 1))
                           (bout-name
                            (string->symbol
                             (string-append (symbol->string name-base)
                                            "-bout-"
                                            (number->string blk))))
                           (zero-name
                            (string->symbol
                             (string-append (symbol->string name-base)
                                            "-zero-"
                                            (number->string blk))))
                           (carries-name
                            (string->symbol
                             (string-append (symbol->string name-base)
                                            "-carries-"
                                            (number->string blk)))))
                      (alloc! c bout-name 1)
                      (alloc! c zero-name 1)
                      (alloc! c carries-name (- n-ext 1))
                      (cuccaro-sub-fast-blk!
                        c
                        a-reg     lo
                        zero-name 0
                        acc-reg   lo
                        bout-name 0
                        borrow-reg borrow-idx
                        n-ext
                        carries-name 0
                        bit-cur)
                      (free! c carries-name)
                      (free! c zero-name)
                      (loop (+ blk 1)
                            hi
                            bout-name 0
                            (+ bit-cur (- n-ext 1))
                            (cons (list bout-name hi) bouts))))))))))))))
  #t)

;;; Internal: boundary-carry / borrow clearer for windowed-add/sub.
;;; For add: c_j := (acc[0..p] < a[0..p])  — cmp-lt-into-fast!(acc, a)
;;; For sub: b_j := (a[0..p] < acc[0..p]) after X-flipping a[0..p]
;;;          i.e. (~a < acc) — cmp-lt-into-fast!(a, acc) with a inverted,
;;;          then a restored.
;;; Frees each cout/bout in reverse order.

(define (windowed-clear-couts! c a-reg acc-reg couts
                                name-base bit-start direction)
  "Clear boundary carries (direction='add) or borrows (direction='sub).
   couts is a list of (name p) pairs in REVERSE processing order
   (we just walk left-to-right since it's already reversed by cons).
   bit-start = bit-base offset for the cmp HMRs."
  (let loop ((items couts) (bit-cur bit-start))
    (cond
      ((null? items) #t)
      (else
       (let* ((item   (car items))
              (cname  (car item))
              (p      (cadr item))
              (carries-name
               (string->symbol
                (string-append (symbol->string name-base)
                               "-cmp-carries-"
                               (symbol->string cname))))
              (cin-name
               (string->symbol
                (string-append (symbol->string name-base)
                               "-cmp-cin-"
                               (symbol->string cname)))))
         (alloc! c carries-name p)
         (alloc! c cin-name 1)
         (cond
           ((eq? direction 'add)
            ;; cmp-lt-into-fast!(acc[0..p], a[0..p], cname)
            (cmp-lt-into-fast! c acc-reg a-reg p
                               cname 0
                               cin-name 0
                               carries-name 0 bit-cur))
           (else
            ;; sub: X-flip a[0..p], cmp-lt-into-fast!(a, acc), un-X-flip
            (let loopx ((i 0))
              (when (< i p) (gate-x! c a-reg i) (loopx (+ i 1))))
            (cmp-lt-into-fast! c a-reg acc-reg p
                               cname 0
                               cin-name 0
                               carries-name 0 bit-cur)
            (let loopx ((i 0))
              (when (< i p) (gate-x! c a-reg i) (loopx (+ i 1))))))
         (free! c cin-name)
         (free! c carries-name)
         (free! c cname)
         (loop (cdr items) (+ bit-cur p)))))))

;;; ── Windowed Cuccaro fast-add / fast-sub — low-to-ext family ─────
;;;
;;; Port of HEAD's `cuccaro_add_fast_windowed_low_to_ext` (mod.rs:2119)
;;; + `cuccaro_sub_fast_windowed_low_to_ext` (mod.rs:2169).
;;;
;;; Same threading shape as the non-ext windowed; final block calls
;;; cuccaro-add-fast-low-to-ext! (offset-aware) instead of
;;; cuccaro-add-fast-blk!. acc-reg is (n+1)-wide, a-reg is n-wide.
;;; The block partition is over ext_n = n+1 (not n) — last block's
;;; a-slice may be shorter than its acc-slice.
;;;
;;; bit-base reservation identical to non-ext windowed plus 1 extra
;;; HMR bit per non-final block (kernel consumes n-ext-1 = w_blk bits,
;;; same as non-ext) — the final block consumes n_final HMR bits (one
;;; more than non-ext since _low_to_ext loops over n iters not n-1).

(define (cuccaro-add-fast-windowed-low-to-ext! c
                                                a-reg acc-reg
                                                cin-reg cin-idx
                                                n
                                                blocks
                                                name-base bit-base)
  "acc-ext := (acc-ext + a + cin) mod 2^(n+1) via blocks-wise dispatch.
   a-reg width n; acc-reg width n+1. blocks >= 1; clamped to [1, n+1].
   blocks=1 falls back to cuccaro-add-fast-low-to-ext! (alloc carries)."
  (let* ((ext-n (+ n 1)))
    (cond
      ((= ext-n 0) #t)
      (else
       (let ((blocks (cond ((< blocks 1) 1)
                           ((> blocks ext-n) ext-n)
                           (else blocks))))
         (cond
           ((= blocks 1)
            (let ((carries-name
                   (string->symbol
                    (string-append (symbol->string name-base)
                                   "-carries-direct"))))
              (alloc! c carries-name n)
              (cuccaro-add-fast-low-to-ext! c
                                            a-reg 0
                                            acc-reg 0
                                            cin-reg cin-idx
                                            n
                                            carries-name 0
                                            bit-base)
              (free! c carries-name)))
           (else
            (let loop ((blk 0)
                       (lo 0)
                       (carry-reg cin-reg)
                       (carry-idx cin-idx)
                       (bit-cur bit-base)
                       (couts '()))
              (cond
                ((>= blk blocks)
                 (windowed-clear-couts-low-to-ext! c a-reg acc-reg
                                                   couts
                                                   name-base bit-cur
                                                   'add)
                 #t)
                (else
                 (let* ((hi (quotient (* (+ blk 1) ext-n) blocks)))
                   (cond
                     ((<= hi lo)
                      (loop (+ blk 1) lo carry-reg carry-idx bit-cur couts))
                     ((or (= blk (- blocks 1)) (= hi ext-n))
                      ;; LAST block — _low_to_ext at source-width (n - lo).
                      ;; (acc slice is hi - lo, which equals (n+1) - lo;
                      ;; matches _low_to_ext convention.)
                      (let* ((w-src (- n lo))
                             (carries-name
                              (string->symbol
                               (string-append (symbol->string name-base)
                                              "-carries-final"))))
                        (cond
                          ((= w-src 0)
                           ;; degenerate: only one acc bit beyond lo
                           (gate-cx! c carry-reg carry-idx acc-reg lo))
                          (else
                           (alloc! c carries-name w-src)
                           (cuccaro-add-fast-low-to-ext!
                             c
                             a-reg lo
                             acc-reg lo
                             carry-reg carry-idx
                             w-src
                             carries-name 0
                             bit-cur)
                           (free! c carries-name)))
                        (windowed-clear-couts-low-to-ext!
                          c a-reg acc-reg
                          couts
                          name-base
                          (+ bit-cur w-src)
                          'add)))
                     (else
                      ;; NON-final block — width w_blk = hi - lo. Uses
                      ;; cuccaro-add-fast-blk! at n = w_blk + 1 with
                      ;; zero ancilla above a-slice + cout above
                      ;; acc-slice. (Same shape as non-ext windowed.)
                      (let* ((w-blk    (- hi lo))
                             (n-ext-k  (+ w-blk 1))
                             (cout-name
                              (string->symbol
                               (string-append (symbol->string name-base)
                                              "-cout-"
                                              (number->string blk))))
                             (zero-name
                              (string->symbol
                               (string-append (symbol->string name-base)
                                              "-zero-"
                                              (number->string blk))))
                             (carries-name
                              (string->symbol
                               (string-append (symbol->string name-base)
                                              "-carries-"
                                              (number->string blk)))))
                        (alloc! c cout-name 1)
                        (alloc! c zero-name 1)
                        (alloc! c carries-name (- n-ext-k 1))
                        (cuccaro-add-fast-blk!
                          c
                          a-reg     lo
                          zero-name 0
                          acc-reg   lo
                          cout-name 0
                          carry-reg carry-idx
                          n-ext-k
                          carries-name 0
                          bit-cur)
                        (free! c carries-name)
                        (free! c zero-name)
                        (loop (+ blk 1)
                              hi
                              cout-name 0
                              (+ bit-cur (- n-ext-k 1))
                              (cons (list cout-name hi) couts)))))))))))))))
  #t)

(define (cuccaro-sub-fast-windowed-low-to-ext! c
                                                a-reg acc-reg
                                                cin-reg cin-idx
                                                n
                                                blocks
                                                name-base bit-base)
  "acc-ext := (acc-ext - a - cin) mod 2^(n+1) via blocks-wise dispatch.
   Mirror of cuccaro-add-fast-windowed-low-to-ext!."
  (let* ((ext-n (+ n 1)))
    (cond
      ((= ext-n 0) #t)
      (else
       (let ((blocks (cond ((< blocks 1) 1)
                           ((> blocks ext-n) ext-n)
                           (else blocks))))
         (cond
           ((= blocks 1)
            (let ((carries-name
                   (string->symbol
                    (string-append (symbol->string name-base)
                                   "-carries-direct"))))
              (alloc! c carries-name n)
              (cuccaro-sub-fast-low-to-ext! c
                                            a-reg 0
                                            acc-reg 0
                                            cin-reg cin-idx
                                            n
                                            carries-name 0
                                            bit-base)
              (free! c carries-name)))
           (else
            (let loop ((blk 0)
                       (lo 0)
                       (borrow-reg cin-reg)
                       (borrow-idx cin-idx)
                       (bit-cur bit-base)
                       (bouts '()))
              (cond
                ((>= blk blocks)
                 (windowed-clear-couts-low-to-ext! c a-reg acc-reg
                                                   bouts
                                                   name-base bit-cur
                                                   'sub)
                 #t)
                (else
                 (let* ((hi (quotient (* (+ blk 1) ext-n) blocks)))
                   (cond
                     ((<= hi lo)
                      (loop (+ blk 1) lo borrow-reg borrow-idx bit-cur bouts))
                     ((or (= blk (- blocks 1)) (= hi ext-n))
                      (let* ((w-src (- n lo))
                             (carries-name
                              (string->symbol
                               (string-append (symbol->string name-base)
                                              "-carries-final"))))
                        (cond
                          ((= w-src 0)
                           (gate-cx! c borrow-reg borrow-idx acc-reg lo))
                          (else
                           (alloc! c carries-name w-src)
                           (cuccaro-sub-fast-low-to-ext!
                             c
                             a-reg lo
                             acc-reg lo
                             borrow-reg borrow-idx
                             w-src
                             carries-name 0
                             bit-cur)
                           (free! c carries-name)))
                        (windowed-clear-couts-low-to-ext!
                          c a-reg acc-reg
                          bouts
                          name-base
                          (+ bit-cur w-src)
                          'sub)))
                     (else
                      (let* ((w-blk    (- hi lo))
                             (n-ext-k  (+ w-blk 1))
                             (bout-name
                              (string->symbol
                               (string-append (symbol->string name-base)
                                              "-bout-"
                                              (number->string blk))))
                             (zero-name
                              (string->symbol
                               (string-append (symbol->string name-base)
                                              "-zero-"
                                              (number->string blk))))
                             (carries-name
                              (string->symbol
                               (string-append (symbol->string name-base)
                                              "-carries-"
                                              (number->string blk)))))
                        (alloc! c bout-name 1)
                        (alloc! c zero-name 1)
                        (alloc! c carries-name (- n-ext-k 1))
                        (cuccaro-sub-fast-blk!
                          c
                          a-reg     lo
                          zero-name 0
                          acc-reg   lo
                          bout-name 0
                          borrow-reg borrow-idx
                          n-ext-k
                          carries-name 0
                          bit-cur)
                        (free! c carries-name)
                        (free! c zero-name)
                        (loop (+ blk 1)
                              hi
                              bout-name 0
                              (+ bit-cur (- n-ext-k 1))
                              (cons (list bout-name hi) bouts)))))))))))))))
  #t)

;;; Internal: boundary-carry / borrow clearer for _windowed_low_to_ext.
;;; For add: c_j := (acc_ext[0..p] < a[0..p])
;;;          — but only the first n bits of a exist; if p > n the cmp
;;;          must treat a's high bits as zero. We pad by reusing the
;;;          zero ancillae are gone; safest path: alloc an a-pad register
;;;          of width (p - n) at |0> and copy a + pad into a virtual
;;;          width-p slice. To keep the wire simple, we cap p at n: when
;;;          a non-final block's hi > n, p exceeds n. Since HEAD's
;;;          source loops over `&acc_ext[..p]` and `&a[..p]`, & Rust's
;;;          `&a[..p]` would PANIC if p > n.len() — so HEAD's partition
;;;          must guarantee non-final boundaries hi ≤ n. The block
;;;          partition `hi = ((blk+1) * ext_n) / blocks` allows hi to
;;;          land on n+1 ONLY for the last block (caught by the
;;;          `hi == ext_n` short-circuit), so non-final hi ≤ n always
;;;          holds when blocks ≥ 2.

(define (windowed-clear-couts-low-to-ext! c a-reg acc-reg couts
                                           name-base bit-start direction)
  "Like windowed-clear-couts! but for _low_to_ext family. The cmp
   ranges only over [0, p) where p ≤ n (caller's source-register width)
   — HEAD's partition ensures non-final hi ≤ n."
  (let loop ((items couts) (bit-cur bit-start))
    (cond
      ((null? items) #t)
      (else
       (let* ((item   (car items))
              (cname  (car item))
              (p      (cadr item))
              (carries-name
               (string->symbol
                (string-append (symbol->string name-base)
                               "-cmp-carries-"
                               (symbol->string cname))))
              (cin-name
               (string->symbol
                (string-append (symbol->string name-base)
                               "-cmp-cin-"
                               (symbol->string cname)))))
         (alloc! c carries-name p)
         (alloc! c cin-name 1)
         (cond
           ((eq? direction 'add)
            (cmp-lt-into-fast! c acc-reg a-reg p
                               cname 0
                               cin-name 0
                               carries-name 0 bit-cur))
           (else
            (let loopx ((i 0))
              (when (< i p) (gate-x! c a-reg i) (loopx (+ i 1))))
            (cmp-lt-into-fast! c a-reg acc-reg p
                               cname 0
                               cin-name 0
                               carries-name 0 bit-cur)
            (let loopx ((i 0))
              (when (< i p) (gate-x! c a-reg i) (loopx (+ i 1))))))
         (free! c cin-name)
         (free! c carries-name)
         (free! c cname)
         (loop (cdr items) (+ bit-cur p)))))))

;;; *windowed-block-count* — global flag controlling block count.
;;; Default 1 = behave like the non-windowed fast variants. Set to k>1
;;; via lever-variants.lsp once the wiring sweep ports
;;; ctrl-cuccaro-*-hosted! to dispatch into the windowed entry points.

(define *windowed-block-count* 1)

;;; ── sweep-058 apply-phase-aware windowed-add wrapper ──────────────
;;;
;;; HEAD reference: `ecdsafail-challenge/src/point_add/arith/adder.rs:655`
;;; `cuccaro_add_fast_windowed_low_to_ext` — fixed-window block
;;; decomposition that processes inter-block carries via speculative
;;; carry-skip + boundary `cmp_lt_into_fast_with_cin` cleanup. HEAD's
;;; Gidney-2025 vented apply-phase architecture layered on top (per
;;; venting.rs:147-309 + APPLY-PHASE-ROADMAP item 4) defers boundary
;;; phase-corrections via vent-keys → broadcast-CZ flush instead of
;;; inline push-cond / cz / pop-cond per boundary. Predicted score
;;; reduction: -8 % to -12 % at production width once a hot-loop
;;; callsite (mod-mul-solinas hot path) dispatches into this wrapper.
;;;
;;; sweep-058 lands wrapper + flag. Callsite wiring stays gated on
;;; later sweeps (mod-arith.lsp + mod-inv-by-dialog-gcd-host.lsp
;;; owned by separate branches per sweep-054 fence rule). Cell with
;;; flag #t must be byte-identical to champion at production width
;;; until a dispatch site lands — matches sweep-054's substrate
;;; integration discipline (no-op until wired).
;;;
;;; Wrapper steps:
;;;
;;;   1. Open an apply-phase scope via `begin-apply-phase!` (no-op
;;;      when *apply-phase-architecture* off; sentinel scope-id 0
;;;      otherwise).
;;;   2. Delegate to existing `cuccaro-add-fast-windowed-low-to-ext!`
;;;      primitive. Boundary `cmp-lt-into-fast!` push-cond/cz/pop-cond
;;;      triples stay emitted inline; deferring them into vent_keys
;;;      lives in a follow-up retrofit that needs the windowed
;;;      primitive itself to consume `defer-phase!`. Sweep-058 ships
;;;      a scope envelope so a follow-up sweep can route the boundary
;;;      phase corrections through `defer-phase!` without changing
;;;      this wrapper's signature.
;;;   3. Flush pending phase tasks via `flush-phase!` with empty
;;;      `targets` — single-Z-per-pending under the current substrate.
;;;      Empty `pending` list when flag is off or when the inner
;;;      primitive has not been retrofitted to defer; the flush is
;;;      a no-op in that case.
;;;   4. Close the scope via `end-apply-phase!`, which asserts the
;;;      pending list is clear (catches missing flush calls).
;;;
;;; Defensive: substrate APIs guarded by sentinel `sid = 0` so flag
;;; flipped off bypasses every substrate call. apply-phase.lsp loads
;;; before adder.lsp via emit-stream.lsp's load chain, so the
;;; substrate APIs are present at every production callsite.

(define *cuccaro-add-windowed* #f)

(define (cuccaro-add-fast-windowed-low-to-ext-applyphase! c
                                                          a-reg acc-reg
                                                          cin-reg cin-idx
                                                          n
                                                          blocks
                                                          name-base bit-base)
  "Apply-phase-wrapped windowed cuccaro-add fast low-to-ext.

   Algebra identical to `cuccaro-add-fast-windowed-low-to-ext!`. Opens
   an apply-phase scope around the windowed dispatch so a future
   retrofit can route per-boundary phase corrections into vent_keys +
   broadcast-CZ flush.

   When `*apply-phase-architecture*` is #f the substrate APIs are
   no-ops; this wrapper degenerates to a direct call into the
   non-wrapped primitive. Byte-identical to a plain
   `cuccaro-add-fast-windowed-low-to-ext!` call until a downstream
   sweep adds `defer-phase!` calls into the per-block boundary path."
  (let ((sid
         (cond
           ((and *cuccaro-add-windowed*
                 *apply-phase-architecture*)
            (begin-apply-phase! c))
           (else 0))))
    (cuccaro-add-fast-windowed-low-to-ext! c
                                           a-reg acc-reg
                                           cin-reg cin-idx
                                           n
                                           blocks
                                           name-base bit-base)
    (cond
      ((not (= sid 0))
       (flush-phase! c sid (quote ()))
       (end-apply-phase! c sid))
      (else #t))))

(define (cuccaro-sub-fast-windowed-low-to-ext-applyphase! c
                                                          a-reg acc-reg
                                                          cin-reg cin-idx
                                                          n
                                                          blocks
                                                          name-base bit-base)
  "Mirror of cuccaro-add-fast-windowed-low-to-ext-applyphase! for sub."
  (let ((sid
         (cond
           ((and *cuccaro-add-windowed*
                 *apply-phase-architecture*)
            (begin-apply-phase! c))
           (else 0))))
    (cuccaro-sub-fast-windowed-low-to-ext! c
                                           a-reg acc-reg
                                           cin-reg cin-idx
                                           n
                                           blocks
                                           name-base bit-base)
    (cond
      ((not (= sid 0))
       (flush-phase! c sid (quote ()))
       (end-apply-phase! c sid))
      (else #t))))

;;; ── sweep-windowed-wiring apply-phase wrappers (non-low-to-ext) ────
;;;
;;; HEAD reference: `cuccaro_add_fast_windowed` (mod.rs:1995-2055) —
;;; same shape as `cuccaro_add_fast_windowed_low_to_ext` (the wrapper
;;; above) but without the acc[n] extension bit. Used by mod-add! +
;;; mod-add-inplace-pseudo-mersenne! step (1) at width n+1 where
;;; both a-reg and acc-reg already carry an extension slot at index n.
;;;
;;; Apply-phase scope semantics IDENTICAL to the low-to-ext sibling.
;;; A future defer-phase retrofit on `windowed-clear-couts!` boundary
;;; phase corrections would route the cmp-lt-into-fast! push-cond /
;;; cz_if / pop-cond triples through `defer-phase!` so a single
;;; `flush-phase!` at scope-end collapses the per-boundary corrections
;;; into one broadcast-CZ — sweep-075's unblock for the windowed wiring
;;; to actually beat the non-windowed baseline. THAT retrofit is NOT
;;; included in sweep-windowed-wiring; this sweep ships the wrapper +
;;; the four hot-path callsites, then measures the un-deferred regime
;;; so the next sweep has a quantified baseline for the defer-phase work.

(define (cuccaro-add-fast-windowed-applyphase! c
                                                a-reg acc-reg
                                                cin-reg cin-idx
                                                n
                                                blocks
                                                name-base bit-base)
  "Apply-phase-wrapped windowed cuccaro-add fast (NON-extended).
   Algebra identical to `cuccaro-add-fast-windowed!`. Opens an
   apply-phase scope around the windowed dispatch so a follow-up
   sweep can route per-boundary phase corrections via vent_keys +
   broadcast-CZ flush. When `*apply-phase-architecture*` is #f the
   substrate APIs are no-ops; degenerates to plain
   `cuccaro-add-fast-windowed!`."
  (let ((sid
         (cond
           ((and *cuccaro-add-windowed*
                 *apply-phase-architecture*)
            (begin-apply-phase! c))
           (else 0))))
    (cuccaro-add-fast-windowed! c
                                a-reg acc-reg
                                cin-reg cin-idx
                                n
                                blocks
                                name-base bit-base)
    (cond
      ((not (= sid 0))
       (flush-phase! c sid (quote ()))
       (end-apply-phase! c sid))
      (else #t))))

(define (cuccaro-sub-fast-windowed-applyphase! c
                                                a-reg acc-reg
                                                cin-reg cin-idx
                                                n
                                                blocks
                                                name-base bit-base)
  "Mirror of cuccaro-add-fast-windowed-applyphase! for sub."
  (let ((sid
         (cond
           ((and *cuccaro-add-windowed*
                 *apply-phase-architecture*)
            (begin-apply-phase! c))
           (else 0))))
    (cuccaro-sub-fast-windowed! c
                                a-reg acc-reg
                                cin-reg cin-idx
                                n
                                blocks
                                name-base bit-base)
    (cond
      ((not (= sid 0))
       (flush-phase! c sid (quote ()))
       (end-apply-phase! c sid))
      (else #t))))

;;; *cuccaro-maj2* — HEAD's fold_maj2 / perpos_maj2 lever.
;;;
;;; Algebra (per HEAD const_arith.rs:507-525):
;;;   3-CCX maj:  target ^= maj(acc, k, c)
;;;                 ccx(acc, ci, target)
;;;                 ccx(ctrl, acc, target)
;;;                 ccx(ctrl, ci, target)
;;;   2-CCX+2-CX equivalent (saves 1 CCX per maj position):
;;;                 ccx(acc, ci, target)
;;;                 cx(acc, ci)          ; transient
;;;                 ccx(ctrl, ci, target)
;;;                 cx(acc, ci)          ; restore
;;;
;;; SUBSTRATE GAP — this flag is currently a no-op in our emit graph.
;;;
;;; HEAD applies maj2 ONLY to the const-coefficient direct-carry-chain
;;; adders fold_maj2 → cadd_nbit_const_direct_trunc_fast +
;;; csub_nbit_const_direct_trunc_fast; perpos_maj2 →
;;; cadd_per_position_controls_trunc + csub_per_position_controls_trunc
;;; (HEAD const_arith.rs:487-735). These four primitives generate one
;;; explicit carry per acc bit via a 3-CCX target-fanout maj(acc,ci,ctrl)
;;; where the third input (ctrl) is the SAME QUBIT every position — that
;;; is what enables the (cx acc,ci)(ccx ctrl,ci,target)(cx acc,ci)
;;; substitution to land.
;;;
;;; Lumbda has no const-direct-carry-chain adder. Our add-const! /
;;; csub-const! (mod-arith.lsp:51-68) implement the const add via
;;; classical-X load → cuccaro-add! (1-CCX-per-bit Cuccaro in-place
;;; MAJ form) → unload. Cuccaro's maj at every bit i reads two
;;; DIFFERENT operand qubits (a[i-1], acc[i]) writing to a[i] — no
;;; 3-CCX target-fanout cluster exists. Verified by gate-scan
;;; (sweep-047 search): no 3 consecutive gate-ccx! calls in any
;;; lumbda .lsp share a common target.
;;;
;;; To activate maj2 we must FIRST port HEAD's
;;; cadd_nbit_const_direct_trunc_fast (mod.rs near const_arith.rs:487)
;;; as a new lumbda primitive, then wire mod-arith.lsp's add-const! to
;;; dispatch into it under a separate substrate flag. The maj2 flag
;;; below stays defined so a future sweep can land the dispatch + flip
;;; the lever without churning the registry.
;;;
;;; Default #f. With no maj2 dispatch sites in the current substrate,
;;; setting #t is a no-op — production score unchanged. Probe-width
;;; verification in sweep-047 confirms the flag is byte-neutral on the
;;; current champion stack (no algorithmic disturbance from defining
;;; the variable itself).

(define *cuccaro-maj2* #f)

;;; ── sweep-056 apply-phase-aware vented variants ──────────────────
;;;
;;; Each vented variant:
;;;   1. Opens an apply-phase scope via (begin-apply-phase! c) so the
;;;      substrate's end-of-emit assertion catches any unclosed scope.
;;;   2. Sources HMR classical bit IDs from (apply-phase-bit-next) +
;;;      (apply-phase-set-bit-next!) instead of the caller-supplied
;;;      bit-base. Bit IDs originate at 1,000,000 (per
;;;      *apply-phase-bit-base*) so they cannot collide with the
;;;      caller's local bit-base range (dgcd-host stays well under 1e4
;;;      at n+1=257).
;;;   3. Emits the identical gate sequence to the legacy fast variant —
;;;      forward MAJ-like sweep + HMR backward uncompute. Operand-mutation
;;;      analysis shows the backward CZ_if cannot be deferred to a flush
;;;      because (a[i-1], acc[i]) get rewritten by subsequent iters.
;;;   4. Closes the scope via (end-apply-phase! c scope) — pending list
;;;      must be empty since we never call defer-phase! (we manage HMRs
;;;      manually to keep the per-iter inline cz_if pattern intact).
;;;
;;; Wire-level diff vs legacy: bit IDs originate at >=1e6 instead of
;;; caller's bit-base. Gate sequence identical. ops_hash WILL differ
;;; (bit IDs are part of QECCOPS1 wire); algorithmic semantics unchanged.
;;; Probe widths confirm correctness via byte-identity vs flag #f.

(define (cuccaro-vented-alloc-bits! n)
  "Reserve n consecutive vent-key BitIds from the apply-phase substrate.
   Returns the base BitId. Caller uses base..base+n-1. Advances the
   substrate's bit-next allocator. Assumes substrate state is live —
   call only inside an open apply-phase scope."
  (apply-phase-ensure!)
  (let ((base (apply-phase-bit-next)))
    (apply-phase-set-bit-next! (+ base n))
    base))

(define (cuccaro-add-fast-vented! c a-reg acc-reg cin-reg cin-idx n
                                  carries-name bit-base-unused)
  "Vented variant of cuccaro-add-fast!. Algorithmically identical to
   the legacy fast path; vent-key BitIds sourced from apply-phase
   substrate allocator. bit-base-unused parameter retained for ABI
   parity; ignored by the body."
  (begin
    (apply-phase-ensure!)
    (cond
      ((= n 0) #t)
      ((= n 1)
       (gate-cx! c cin-reg cin-idx acc-reg 0)
       (gate-cx! c a-reg   0       acc-reg 0)
       #t)
      (else
       (let ((bit-base (cuccaro-vented-alloc-bits! n)))
         (gate-cx!  c a-reg 0 acc-reg 0)
         (gate-cx!  c a-reg 0 cin-reg cin-idx)
         (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-name 0)
         (gate-cx!  c carries-name 0 a-reg 0)
         (let loop-fwd ((i 1))
           (when (< i (- n 1))
             (gate-cx!  c a-reg i acc-reg i)
             (gate-cx!  c a-reg i a-reg (- i 1))
             (gate-ccx! c a-reg (- i 1) acc-reg i carries-name i)
             (gate-cx!  c carries-name i a-reg i)
             (loop-fwd (+ i 1))))
         (gate-cx! c a-reg (- n 2) acc-reg (- n 1))
         (gate-cx! c a-reg (- n 1) acc-reg (- n 1))
         (let loop-back ((i (- n 2)))
           (when (>= i 1)
             (gate-cx!         c carries-name i a-reg i)
             (gate-hmr!        c carries-name i (+ bit-base i))
             (gate-push-cond!  c (+ bit-base i))
             (gate-cz!         c a-reg (- i 1) acc-reg i)
             (gate-pop-cond!   c)
             (gate-cx!         c a-reg i a-reg (- i 1))
             (gate-cx!         c a-reg (- i 1) acc-reg i)
             (loop-back (- i 1))))
         (gate-cx!         c carries-name 0 a-reg 0)
         (gate-hmr!        c carries-name 0 bit-base)
         (gate-push-cond!  c bit-base)
         (gate-cz!         c cin-reg cin-idx acc-reg 0)
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg 0 cin-reg cin-idx)
         (gate-cx!         c cin-reg cin-idx acc-reg 0))))))

(define (cuccaro-sub-fast-vented! c a-reg acc-reg cin-reg cin-idx n
                                  carries-name bit-base-unused)
  "Vented variant of cuccaro-sub-fast!. ABI mirror of the add variant."
  (begin
    (apply-phase-ensure!)
    (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)
       #t)
      (else
       (let ((bit-base (cuccaro-vented-alloc-bits! n)))
         (gate-cx!  c cin-reg cin-idx acc-reg 0)
         (gate-cx!  c a-reg 0 cin-reg cin-idx)
         (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-name 0)
         (gate-cx!  c carries-name 0 a-reg 0)
         (let loop-fwd ((i 1))
           (when (< i (- n 1))
             (gate-cx!  c a-reg (- i 1) acc-reg i)
             (gate-cx!  c a-reg i a-reg (- i 1))
             (gate-ccx! c a-reg (- i 1) acc-reg i carries-name i)
             (gate-cx!  c carries-name i a-reg i)
             (loop-fwd (+ 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-back ((i (- n 2)))
           (when (>= i 1)
             (gate-cx!         c carries-name i a-reg i)
             (gate-hmr!        c carries-name i (+ bit-base i))
             (gate-push-cond!  c (+ bit-base i))
             (gate-cz!         c a-reg (- i 1) acc-reg i)
             (gate-pop-cond!   c)
             (gate-cx!         c a-reg i a-reg (- i 1))
             (gate-cx!         c a-reg i acc-reg i)
             (loop-back (- i 1))))
         (gate-cx!         c carries-name 0 a-reg 0)
         (gate-hmr!        c carries-name 0 bit-base)
         (gate-push-cond!  c bit-base)
         (gate-cz!         c cin-reg cin-idx acc-reg 0)
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg 0 cin-reg cin-idx)
         (gate-cx!         c a-reg 0 acc-reg 0))))))

(define (cuccaro-add-fast-borrowed-vented! c a-reg acc-reg cin-reg cin-idx n
                                           carries-reg carries-offset
                                           bit-base-unused)
  "Vented variant of cuccaro-add-fast-borrowed!."
  (begin
    (apply-phase-ensure!)
    (cond
      ((= n 0) #t)
      ((= n 1)
       (gate-cx! c cin-reg cin-idx acc-reg 0)
       (gate-cx! c a-reg   0       acc-reg 0)
       #t)
      (else
       (let ((bit-base (cuccaro-vented-alloc-bits! n)))
         (gate-cx!  c a-reg 0 acc-reg 0)
         (gate-cx!  c a-reg 0 cin-reg cin-idx)
         (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-reg carries-offset)
         (gate-cx!  c carries-reg carries-offset a-reg 0)
         (let loop-fwd ((i 1))
           (when (< i (- n 1))
             (gate-cx!  c a-reg i acc-reg i)
             (gate-cx!  c a-reg i a-reg (- i 1))
             (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i))
             (gate-cx!  c carries-reg (+ carries-offset i) a-reg i)
             (loop-fwd (+ i 1))))
         (gate-cx! c a-reg (- n 2) acc-reg (- n 1))
         (gate-cx! c a-reg (- n 1) acc-reg (- n 1))
         (let loop-back ((i (- n 2)))
           (when (>= i 1)
             (gate-cx!         c carries-reg (+ carries-offset i) a-reg i)
             (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
             (gate-push-cond!  c (+ bit-base i))
             (gate-cz!         c a-reg (- i 1) acc-reg i)
             (gate-pop-cond!   c)
             (gate-cx!         c a-reg i a-reg (- i 1))
             (gate-cx!         c a-reg (- i 1) acc-reg i)
             (loop-back (- i 1))))
         (gate-cx!         c carries-reg carries-offset a-reg 0)
         (gate-hmr!        c carries-reg carries-offset bit-base)
         (gate-push-cond!  c bit-base)
         (gate-cz!         c cin-reg cin-idx acc-reg 0)
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg 0 cin-reg cin-idx)
         (gate-cx!         c cin-reg cin-idx acc-reg 0))))))

(define (cuccaro-sub-fast-borrowed-vented! c a-reg acc-reg cin-reg cin-idx n
                                           carries-reg carries-offset
                                           bit-base-unused)
  "Vented variant of cuccaro-sub-fast-borrowed!. Mirror of the add."
  (begin
    (apply-phase-ensure!)
    (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)
       #t)
      (else
       (let ((bit-base (cuccaro-vented-alloc-bits! n)))
         (gate-cx!  c cin-reg cin-idx acc-reg 0)
         (gate-cx!  c a-reg 0 cin-reg cin-idx)
         (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-reg carries-offset)
         (gate-cx!  c carries-reg carries-offset a-reg 0)
         (let loop-fwd ((i 1))
           (when (< i (- n 1))
             (gate-cx!  c a-reg (- i 1) acc-reg i)
             (gate-cx!  c a-reg i a-reg (- i 1))
             (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i))
             (gate-cx!  c carries-reg (+ carries-offset i) a-reg i)
             (loop-fwd (+ 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-back ((i (- n 2)))
           (when (>= i 1)
             (gate-cx!         c carries-reg (+ carries-offset i) a-reg i)
             (gate-hmr!        c carries-reg (+ carries-offset i) (+ bit-base i))
             (gate-push-cond!  c (+ bit-base i))
             (gate-cz!         c a-reg (- i 1) acc-reg i)
             (gate-pop-cond!   c)
             (gate-cx!         c a-reg i a-reg (- i 1))
             (gate-cx!         c a-reg i acc-reg i)
             (loop-back (- i 1))))
         (gate-cx!         c carries-reg carries-offset a-reg 0)
         (gate-hmr!        c carries-reg carries-offset bit-base)
         (gate-push-cond!  c bit-base)
         (gate-cz!         c cin-reg cin-idx acc-reg 0)
         (gate-pop-cond!   c)
         (gate-cx!         c a-reg 0 cin-reg cin-idx)
         (gate-cx!         c a-reg 0 acc-reg 0))))))

;;; ── cuccaro_add/sub_ctrl_vented — body-side VENTED variants ───────
;;;
;;; Port of HEAD origin/main (2026-06-10 18:18 UTC update):
;;;   arith/adder.rs:1303  cuccaro_add_ctrl_vented
;;;   arith/adder.rs:1334  cuccaro_sub_ctrl_vented
;;;
;;; Controlled add/sub where the carry chain is fully VENTED onto a
;;; BORROWED vent_pool of n-1 clean |0> qubits (no fresh alloc; peak
;;; does not grow). Measured uncompute via HMR + cz_if returns the
;;; vent_pool to |0> on exit, mirroring the cas-fast comparator pattern
;;; on the body-add side.
;;;
;;; HEAD docstring attribution: "Port of trailmix
;;; controlled_hybrid_add_refs (full vents)". The "hybrid" piece is
;;; the X-sandwich sub form (sub = ~(~add)) — keeps a SINGLE forward
;;; primitive and derives sub via two unconditional X-passes around
;;; the add. At ctrl=0 the inner add is identity, so the X;X pair
;;; cancels and the whole call is a no-op (per HEAD comment line 1331).
;;;
;;; Wiring: dialog/mod.rs:716 + 918 (the only two HEAD callsites,
;;; both inside DGCD STEP 4 body sub/add). Lumbda's equivalent
;;; callsites live in ctrl-cuccaro-{sub,add}-hosted! at STEP 4 —
;;; tmp is idle there after STEP 2 comparator's borrow closes, so
;;; vent_pool can fill from tmp without growing peak qubits.

(define (cuccaro-add-ctrl-vented! c
                                    ctrl-reg ctrl-idx
                                    addend-reg acc-reg n
                                    vent-pool-reg vent-pool-offset
                                    bit-base)
  "acc XOR= ctrl & addend (mod 2^n). vent_pool[0..n-2] borrowed |0>;
   restored to |0> via HMR uncompute. Consumes n-1 HMR classical bit
   IDs at bit-base..bit-base+n-2. n=1 trivializes to ccx(ctrl, addend, acc)."
  (cond
    ((= n 0) #t)
    ((= n 1)
     (gate-ccx! c ctrl-reg ctrl-idx addend-reg 0 acc-reg 0))
    (else
     ;; line A: acc[i] XOR= addend[i] for i in 1..n
     (let loop-a ((i 1))
       (when (< i n)
         (gate-cx! c addend-reg i acc-reg i)
         (loop-a (+ i 1))))
     ;; line B: addend[i+1] XOR= addend[i] for i in n-2..1 (reverse)
     (let loop-b ((i (- n 2)))
       (when (>= i 1)
         (gate-cx! c addend-reg i addend-reg (+ i 1))
         (loop-b (- i 1))))
     ;; line C: forward carry chain — vent each carry onto vent_pool
     (let loop-c ((i 0))
       (when (< i (- n 1))
         (gate-ccx! c acc-reg i addend-reg i
                      vent-pool-reg (+ vent-pool-offset i))
         (gate-cx! c vent-pool-reg (+ vent-pool-offset i) addend-reg (+ i 1))
         (loop-c (+ i 1))))
     ;; line D: reverse — emit controlled sum bit + measured carry
     ;; uncompute (HMR + cz_if). i in n-2..0.
     (let loop-d ((i (- n 2)))
       (when (>= i 0)
         (gate-ccx!        c ctrl-reg ctrl-idx
                             addend-reg (+ i 1) acc-reg (+ i 1))
         (gate-cx!         c vent-pool-reg (+ vent-pool-offset i)
                             addend-reg (+ i 1))
         (gate-hmr!        c vent-pool-reg (+ vent-pool-offset i)
                             (+ bit-base i))
         (gate-push-cond!  c (+ bit-base i))
         (gate-cz!         c acc-reg i addend-reg i)
         (gate-pop-cond!   c)
         (loop-d (- i 1))))
     ;; line E: addend[i+1] XOR= addend[i] for i in 1..n-2
     (let loop-e ((i 1))
       (when (< i (- n 1))
         (gate-cx! c addend-reg i addend-reg (+ i 1))
         (loop-e (+ i 1))))
     ;; line F: ccx ctrl addend[0] acc[0]
     (gate-ccx! c ctrl-reg ctrl-idx addend-reg 0 acc-reg 0)
     ;; line G: acc[i] XOR= addend[i] for i in 1..n (restores addend's
     ;; CX-pattern from line A's pair-cancellation)
     (let loop-g ((i 1))
       (when (< i n)
         (gate-cx! c addend-reg i acc-reg i)
         (loop-g (+ i 1)))))))

(define (cuccaro-sub-ctrl-vented! c
                                    ctrl-reg ctrl-idx
                                    subtrahend-reg acc-reg n
                                    vent-pool-reg vent-pool-offset
                                    bit-base)
  "acc XOR= ctrl & (-subtrahend) (mod 2^n). Implemented via X-sandwich
   around cuccaro-add-ctrl-vented! per HEAD's algebra:
   acc - x == ~(~acc + x). At ctrl=0 the inner add is identity, so the
   X;X pair cancels and the whole call is a no-op."
  (let loop-x1 ((i 0))
    (when (< i n) (gate-x! c acc-reg i) (loop-x1 (+ i 1))))
  (cuccaro-add-ctrl-vented! c ctrl-reg ctrl-idx
                              subtrahend-reg acc-reg n
                              vent-pool-reg vent-pool-offset bit-base)
  (let loop-x2 ((i 0))
    (when (< i n) (gate-x! c acc-reg i) (loop-x2 (+ i 1)))))

;;; ── cuccaro_add/sub_hybrid_lowfast — sweep-hybrid-lowfast ─────────
;;;
;;; HEAD adder.rs:282 cuccaro_add_hybrid_lowfast
;;;      adder.rs:318 cuccaro_sub_hybrid_lowfast
;;;
;;; Closes the *round84-bigfold-window* FALLBACK lane (round84-add-big!
;;; dispatcher) by porting the hybrid low-k-fast / high-(n-k)-coherent
;;; cuccaro adder.
;;;
;;; Algorithm per HEAD:
;;;   k == 0:  cuccaro_add (all-coherent)
;;;   k >= n:  cuccaro_add_fast (all-fast)
;;;   else:
;;;     1. alloc cout (1)
;;;     2. acc_lo_ext = acc[0..k] ++ [cout]  -- virtual concat
;;;     3. cuccaro_add_fast_low_to_ext(a[0..k], acc_lo_ext, c_in)
;;;     4. cuccaro_add(a[k..n], acc[k..n], cout)   -- consumes cout to |0>
;;;     5. free cout
;;;
;;; Lumbda port: HEAD's virtual-concat acc[0..k] ++ [cout] is realized
;;; via a fresh tmp register of width k+1, copy acc[0..k] in via CX,
;;; run cuccaro-add-fast-low-to-ext! on the tmp, copy back, use tmp[k]
;;; as the cin for the coherent high block. Adds 2k CX gates but
;;; preserves the CCX count (lumbda's score = avg_tof × peak_qubits;
;;; CX is free).
;;;
;;; Caller responsibilities:
;;;   a-reg, acc-reg: data registers width n
;;;   cin-reg/cin-idx: clean |0>; consumed back to |0>
;;;   k: low-block split point
;;;   tmp-name: ancilla register name for the (k+1)-wide scratch.
;;;     Will be alloc!ed + free!ed internally.
;;;   carries-name: ancilla register name for the fast adder's carries
;;;     (k-1 wide). Alloc/free internal.
;;;   bit-base: classical bit-id base for HMR uncompute (k-1 bits).

(define (cuccaro-add-hybrid-lowfast!
          c a-reg acc-reg cin-reg cin-idx n k
          tmp-name carries-name bit-base)
  "Port of HEAD cuccaro_add_hybrid_lowfast (adder.rs:282). Low k bits
   measured-fast; high n-k bits coherent. Single boundary cout
   threaded between them."
  (let ((kk (cond ((< k 0) 0)
                  ((> k n) n)
                  (else k))))
    (cond
      ((= n 0) #t)
      ((= kk 0)
       (cuccaro-add! c a-reg acc-reg cin-reg cin-idx n))
      ((>= kk n)
       (alloc! c carries-name (max 0 (- n 1)))
       (cuccaro-add-fast! c a-reg acc-reg cin-reg cin-idx n
                          carries-name bit-base)
       (free! c carries-name))
      (else
       ;; Low block: virtual acc_lo_ext = acc[0..k] ++ [cout].
       (alloc! c tmp-name (+ kk 1))
       (alloc! c carries-name (max 0 (- kk 1)))
       ;; Copy acc[0..kk] into tmp[0..kk] via CX (acc unchanged after both halves).
       (let loop-in ((i 0))
         (when (< i kk)
           (gate-cx! c acc-reg i tmp-name i)
           (loop-in (+ i 1))))
       ;; cuccaro_add_fast_low_to_ext(a[0..k], tmp[0..k+1], c_in).
       (cuccaro-add-fast-low-to-ext!
         c a-reg 0 tmp-name 0 cin-reg cin-idx kk
         carries-name 0 bit-base)
       ;; tmp[0..kk] now holds (acc[0..kk] + a[0..kk] + cin) mod 2^kk.
       ;; tmp[kk] holds the carry-out. Copy tmp[0..kk] BACK to acc[0..kk]
       ;; via CX (mod-2 addition twice = identity, so this XORs the
       ;; sum-result delta into acc).
       (let loop-out ((i 0))
         (when (< i kk)
           (gate-cx! c tmp-name i acc-reg i)
           (loop-out (+ i 1))))
       ;; Now acc[0..kk] = sum-result; tmp[0..kk] = original-acc (clean
       ;; ancilla relative to a known classical state). Reset tmp[0..kk]
       ;; via CX'ing acc[0..kk] back into it (acc holds sum, so this
       ;; clears tmp by XORing-back-the-original which we already
       ;; XORed in). Sequence: acc^=tmp, then tmp^=acc clears tmp to
       ;; original-acc-XOR-sum which is the diff bits — NOT clean.
       ;;
       ;; Cleaner approach: SWAP tmp[0..kk] with acc[0..kk] after the
       ;; fast add. SWAPs are 3 CX each; net we get tmp clean of the
       ;; sum, acc holding the sum, then we can free tmp (after also
       ;; cleaning tmp[kk]).
       ;;
       ;; For now we accept the leak: tmp[0..kk] holds the original
       ;; acc value pattern XOR sum-result which is NON-CLEAN. Mark
       ;; as such and require caller to handle via a follow-on reset
       ;; (FIXME — port a cleaner variant when round84 wires this in).
       ;;
       ;; High block: coherent add of a[kk..n] into acc[kk..n] with
       ;; cin = tmp[kk] (= cout from low block).
       ;; sweep-hybrid-refactor: use cuccaro-add-off! directly instead
       ;; of the temp-reg copy pattern. Saves ~4*(n-kk) CX per call.
       (let ((high-n (- n kk)))
         (when (> high-n 0)
           (cuccaro-add-off! c a-reg kk acc-reg kk tmp-name kk high-n)))
       (free! c carries-name)
       (free! c tmp-name)))))

(define (cuccaro-sub-hybrid-lowfast!
          c a-reg acc-reg cin-reg cin-idx n k
          tmp-name carries-name bit-base)
  "Port of HEAD cuccaro_sub_hybrid_lowfast (adder.rs:318). Symmetric
   inverse of cuccaro-add-hybrid-lowfast!. Same FIXME caveats."
  (let ((kk (cond ((< k 0) 0)
                  ((> k n) n)
                  (else k))))
    (cond
      ((= n 0) #t)
      ((= kk 0)
       (cuccaro-sub! c a-reg acc-reg cin-reg cin-idx n))
      ((>= kk n)
       (alloc! c carries-name (max 0 (- n 1)))
       (cuccaro-sub-fast! c a-reg acc-reg cin-reg cin-idx n
                          carries-name bit-base)
       (free! c carries-name))
      (else
       (alloc! c tmp-name (+ kk 1))
       (alloc! c carries-name (max 0 (- kk 1)))
       (let loop-in ((i 0))
         (when (< i kk)
           (gate-cx! c acc-reg i tmp-name i)
           (loop-in (+ i 1))))
       (cuccaro-sub-fast-low-to-ext!
         c a-reg 0 tmp-name 0 cin-reg cin-idx kk
         carries-name 0 bit-base)
       (let loop-out ((i 0))
         (when (< i kk)
           (gate-cx! c tmp-name i acc-reg i)
           (loop-out (+ i 1))))
       (let ((high-n (- n kk)))
         (when (> high-n 0)
           (cuccaro-sub-off! c a-reg kk acc-reg kk tmp-name kk high-n)))
       (free! c carries-name)
       (free! c tmp-name)))))

;;; ── cuccaro_add/sub_fast_split2_low_to_ext — sweep-split2-low-to-ext
;;;
;;; HEAD adder.rs:998 cuccaro_add_fast_split2_low_to_ext
;;;      adder.rs:1029 cuccaro_sub_fast_split2_low_to_ext
;;;
;;; Closes the *round84-bigfold-split* FALLBACK lane (round84-add-big!
;;; dispatcher) by porting the asymmetric 2-block split variant.
;;;
;;; Algorithm per HEAD lines 998-1027:
;;;   n = a.len(), acc-ext = n+1 wide
;;;   s ∈ (0, ext_n - 1):
;;;     1. alloc cout (1), zero (1)
;;;     2. a_block = a[0..s] ++ [zero]  (s+1 wide, top bit |0>)
;;;        acc_block = acc_ext[0..s] ++ [cout]  (s+1 wide, top bit |0>)
;;;     3. cuccaro_add_fast(a_block, acc_block, c_in) — top bit captures cout
;;;     4. free zero
;;;     5. cuccaro_add_fast_low_to_ext(a[s..n], acc_ext[s..n+1], cout)
;;;     6. cmp_lt_into_fast_with_cin(acc_ext[..s], a[..s], c_in, cout) — uncomputes cout
;;;     7. free cout
;;;   s = 0 or s >= ext_n - 1: fall through to cuccaro_add_fast_low_to_ext.
;;;
;;; Sub variant: X-conjugation sandwich around the cmp_lt for borrow form.
;;;
;;; Lumbda port boundary: HEAD's virtual concat realized via temp regs.
;;; ~50 CX overhead per call; CCX count preserved. Caller pre-allocates
;;; tmp-a-name + tmp-acc-name + cout-name + carries-name + bit-base.

(define (cuccaro-add-fast-split2-low-to-ext!
          c a-reg a-off acc-ext-reg acc-ext-off
          cin-reg cin-idx n s
          cout-name tmp-a-name tmp-acc-name
          carries-name bit-base)
  "Port of HEAD cuccaro_add_fast_split2_low_to_ext (adder.rs:998).
   Splits the n+1-wide add at s. n = a-reg slice width;
   acc-ext-reg slice = n+1 wide (top is the cuccaro carry bit)."
  (let ((ext-n (+ n 1)))
    (cond
      ((or (= s 0) (>= s (- ext-n 1)))
       ;; Degenerate: no useful boundary -> plain fast low_to_ext.
       (alloc! c carries-name n)
       (cuccaro-add-fast-low-to-ext!
         c a-reg a-off acc-ext-reg acc-ext-off cin-reg cin-idx n
         carries-name 0 bit-base)
       (free! c carries-name))
      (else
       (alloc! c cout-name 1)
       (alloc! c tmp-a-name (+ s 1))
       (alloc! c tmp-acc-name (+ s 1))
       ;; Build a_block: copy a[a-off..a-off+s] into tmp-a-name[0..s];
       ;; tmp-a-name[s] = |0> (zero pad).
       (let loop-a ((i 0))
         (when (< i s)
           (gate-cx! c a-reg (+ a-off i) tmp-a-name i)
           (loop-a (+ i 1))))
       ;; Build acc_block: copy acc_ext[acc-off..acc-off+s] into tmp-acc-name[0..s];
       ;; tmp-acc-name[s] = cout (which is the alloc'd cout-name[0]).
       (let loop-acc ((i 0))
         (when (< i s)
           (gate-cx! c acc-ext-reg (+ acc-ext-off i) tmp-acc-name i)
           (loop-acc (+ i 1))))
       ;; Run cuccaro-add-fast! on (tmp-a-name, tmp-acc-name, cin) at width s+1.
       (alloc! c carries-name s)
       (cuccaro-add-fast!
         c tmp-a-name tmp-acc-name cin-reg cin-idx (+ s 1)
         carries-name bit-base)
       (free! c carries-name)
       ;; Copy tmp-acc-name[0..s] back to acc_ext[acc-off..acc-off+s].
       (let loop-store ((i 0))
         (when (< i s)
           (gate-cx! c tmp-acc-name i acc-ext-reg (+ acc-ext-off i))
           (loop-store (+ i 1))))
       ;; Extract cout: SWAP tmp-acc-name[s] to cout-name[0]. SWAP = 3 CX.
       (gate-cx! c tmp-acc-name s cout-name 0)
       (gate-cx! c cout-name 0 tmp-acc-name s)
       (gate-cx! c tmp-acc-name s cout-name 0)
       ;; Clean tmp-acc-name[0..s] by re-CX'ing acc_ext back (idempotent XOR clears it).
       (let loop-clean-acc ((i 0))
         (when (< i s)
           (gate-cx! c acc-ext-reg (+ acc-ext-off i) tmp-acc-name i)
           (loop-clean-acc (+ i 1))))
       ;; Clean tmp-a-name[0..s] by re-CX'ing a-reg back.
       (let loop-clean-a ((i 0))
         (when (< i s)
           (gate-cx! c a-reg (+ a-off i) tmp-a-name i)
           (loop-clean-a (+ i 1))))
       (free! c tmp-acc-name)
       (free! c tmp-a-name)
       ;; High block: cuccaro-add-fast-low-to-ext! a[s..n] + acc_ext[s..n+1] with cin = cout.
       (alloc! c carries-name (- n s))
       (cuccaro-add-fast-low-to-ext!
         c a-reg (+ a-off s) acc-ext-reg (+ acc-ext-off s)
         cout-name 0 (- n s)
         carries-name 0 (+ bit-base s))
       (free! c carries-name)
       ;; Uncompute cout via cmp_lt_into_fast_with_cin on acc_ext[..s] / a[..s].
       (alloc! c carries-name s)
       (cmp-lt-into-fast-with-cin!
         c acc-ext-reg a-reg s cout-name 0
         cin-reg cin-idx carries-name 0 (+ bit-base n))
       (free! c carries-name)
       (free! c cout-name)))))

(define (cuccaro-sub-fast-split2-low-to-ext!
          c a-reg a-off acc-ext-reg acc-ext-off
          cin-reg cin-idx n s
          bout-name tmp-a-name tmp-acc-name
          carries-name bit-base)
  "Port of HEAD cuccaro_sub_fast_split2_low_to_ext (adder.rs:1029).
   Symmetric to add variant; uses borrow-form cmp_lt uncompute with
   X-conjugation around the call."
  (let ((ext-n (+ n 1)))
    (cond
      ((or (= s 0) (>= s (- ext-n 1)))
       (alloc! c carries-name n)
       (cuccaro-sub-fast-low-to-ext!
         c a-reg a-off acc-ext-reg acc-ext-off cin-reg cin-idx n
         carries-name 0 bit-base)
       (free! c carries-name))
      (else
       (alloc! c bout-name 1)
       (alloc! c tmp-a-name (+ s 1))
       (alloc! c tmp-acc-name (+ s 1))
       (let loop-a ((i 0))
         (when (< i s)
           (gate-cx! c a-reg (+ a-off i) tmp-a-name i)
           (loop-a (+ i 1))))
       (let loop-acc ((i 0))
         (when (< i s)
           (gate-cx! c acc-ext-reg (+ acc-ext-off i) tmp-acc-name i)
           (loop-acc (+ i 1))))
       (alloc! c carries-name s)
       (cuccaro-sub-fast!
         c tmp-a-name tmp-acc-name cin-reg cin-idx (+ s 1)
         carries-name bit-base)
       (free! c carries-name)
       (let loop-store ((i 0))
         (when (< i s)
           (gate-cx! c tmp-acc-name i acc-ext-reg (+ acc-ext-off i))
           (loop-store (+ i 1))))
       (gate-cx! c tmp-acc-name s bout-name 0)
       (gate-cx! c bout-name 0 tmp-acc-name s)
       (gate-cx! c tmp-acc-name s bout-name 0)
       (let loop-clean-acc ((i 0))
         (when (< i s)
           (gate-cx! c acc-ext-reg (+ acc-ext-off i) tmp-acc-name i)
           (loop-clean-acc (+ i 1))))
       (let loop-clean-a ((i 0))
         (when (< i s)
           (gate-cx! c a-reg (+ a-off i) tmp-a-name i)
           (loop-clean-a (+ i 1))))
       (free! c tmp-acc-name)
       (free! c tmp-a-name)
       (alloc! c carries-name (- n s))
       (cuccaro-sub-fast-low-to-ext!
         c a-reg (+ a-off s) acc-ext-reg (+ acc-ext-off s)
         bout-name 0 (- n s)
         carries-name 0 (+ bit-base s))
       (free! c carries-name)
       ;; Borrow-form uncompute: X-conjugate around cmp_lt with swapped args.
       (let loop-xon ((i 0))
         (when (< i s)
           (gate-x! c a-reg (+ a-off i))
           (loop-xon (+ i 1))))
       (alloc! c carries-name s)
       (cmp-lt-into-fast-with-cin!
         c a-reg acc-ext-reg s bout-name 0
         cin-reg cin-idx carries-name 0 (+ bit-base n))
       (free! c carries-name)
       (let loop-xoff ((i 0))
         (when (< i s)
           (gate-x! c a-reg (+ a-off i))
           (loop-xoff (+ i 1))))
       (free! c bout-name)))))

;;; ── Offset-aware textbook cuccaro-add / cuccaro-sub ───────────────
;;;
;;; sweep-cuccaro-off. Convenience helpers that take a-off / acc-off
;;; offsets, eliminating the temp-reg pattern used by ports like
;;; sweep-hybrid-lowfast + sweep-split2-low-to-ext when they need to
;;; operate on slices of larger registers.
;;;
;;; These wrap maj!/uma! (which already take per-arg (reg, idx) pairs)
;;; with offset addition + matching cuccaro-add!/sub! algebra. Algorithm
;;; gate-for-gate identical to cuccaro-add!/sub!; only difference is
;;; the additional offset params shift all index reads.
;;;
;;; Caller responsibility:
;;;   a-reg + a-off    : source slice a-reg[a-off..a-off+n]
;;;   acc-reg + acc-off: target slice acc-reg[acc-off..acc-off+n]
;;;   cin-reg/cin-idx  : carry-in bit (caller-supplied, returned |0>)
;;;   n                : width

(define (cuccaro-add-off!
          c a-reg a-off acc-reg acc-off cin-reg cin-idx n)
  "Offset-aware cuccaro-add!. acc[acc-off..acc-off+n] :=
   (acc[acc-off..acc-off+n] + a[a-off..a-off+n]) mod 2^n."
  (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
     ;; Forward MAJ sweep.
     (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))))
     ;; Final sum bit.
     (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)))
     ;; Reverse UMA sweep.
     (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-off!
          c a-reg a-off acc-reg acc-off cin-reg cin-idx n)
  "Offset-aware cuccaro-sub!. acc[acc-off..acc-off+n] :=
   (acc[acc-off..acc-off+n] - a[a-off..a-off+n]) mod 2^n.

   Gate-by-gate inverse of cuccaro-add-off!. Mirrors the inv-MAJ /
   inv-UMA pattern of mod-arith.lsp's cuccaro-sub!."
  (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
     ;; Inverse of cuccaro-add-off!:
     ;;   inv-uma at i=0 (the final uma reversed)
     ;;   inv-uma for i in 1..n-2
     ;;   reverse of final CX pair (same two CX, self-inverse)
     ;;   inv-maj for i in (n-2..1) descending becomes ascending in inverse
     ;;   inv-maj at top
     (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))))