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

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

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

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

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

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

2824 lines
127 KiB
Text
Raw Permalink Blame History

This file contains ambiguous Unicode characters

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

;;; 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))))
Reference in a new issue View git blame Copy permalink