engineering/lumbda
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions
lumbda/quantum/mod-arith.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

6127 lines
281 KiB
Text
Raw Blame History

This file contains ambiguous Unicode characters

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

;;; mod-arith.lsp — reversible modular arithmetic over a generic prime.
;;;
;;; Public surface: bit-set?, load-const!, unload-const!, cload-const!,
;;; cunload-const!, add-const!, csub-const!, inv-maj!, cmp-lt-into!,
;;; mod-add!, mod-sub!, mod-mul!, mod-double-inplace!, mod-halve-inplace!,
;;; mod-shift-left/right-by-k-lowq!, mod-add-qb!, mod-sub-qb!. Layer
;;; sits on adder.lsp (Cuccaro ripple-carry).
;;;
;;; mod-add CALLING CONVENTION: caller passes a-reg & acc-reg as
;;; (n+1)-wide registers, top bit held at |0> (extension ancilla).
;;; Caller also allocates cin (1 bit), tmp (n+1 bits), flag (1 bit).
;;; All ancillae return to |0>; top bit of a-reg & acc-reg also returns
;;; to |0> on exit.
;;;
;;; ── *field-prime* convention ─────────────────────────────────────
;;;
;;; Primitives take `p` as explicit argument (p = field prime, integer).
;;; New upstream consumers can ALSO set `*field-prime*` at program top
;;; so layer code reads a single source of truth & avoids threading p
;;; through every wrapper. Foxhop callers still pass p directly.
;;;
;;; Public mod-* primitives assert *field-prime* matches their `p` arg
;;; if both are set, otherwise accept caller's `p` as authoritative.
(define *field-prime* #f)
;; Consumer binds via (set! *field-prime* <p>) before calling mod-arith
;; primitives. Stays #f when not used; primitives derive width from
;; (bit-length p) or accept width via caller arg.
(load "quantum/gates.lsp")
(load "quantum/adder.lsp")
;;; ── classical-constant load/unload ─────────────────────────────
(define (bit-set? k i)
"Is bit i (0-indexed) set in classical integer k?"
(= 1 (remainder (quotient k (expt 2 i)) 2)))
(define (load-const! c reg n k)
"Apply X to reg[i] for every i in [0,n) where bit i of k is 1.
reg starts |0> n-wide; ends holding the bit pattern of k mod 2^n."
(let loop ((i 0))
(when (< i n)
(when (bit-set? k i) (gate-x! c reg i))
(loop (+ i 1)))))
(define (unload-const! c reg n k) (load-const! c reg n k))
(define (cload-const! c ctrl-reg ctrl-idx tgt-reg n k)
"Apply CX(ctrl, tgt[i]) for every i where bit i of k is 1."
(let loop ((i 0))
(when (< i n)
(when (bit-set? k i) (gate-cx! c ctrl-reg ctrl-idx tgt-reg i))
(loop (+ i 1)))))
(define (cunload-const! c ctrl-reg ctrl-idx tgt-reg n k)
(cload-const! c ctrl-reg ctrl-idx tgt-reg n k))
;;; ── extcarry_clean family — sweep-extcarry-clean ──────────────────
;;;
;;; HEAD const_arith.rs:239,251,274,289,317,331. Closes AUDIT §6
;;; rows 208-212.
;;;
;;; Pattern (HEAD lines 257-269 + symmetric): each primitive
;;; 1. load const c into `ca` register (cx-from-ctrl for controlled
;;; variants, x for uncontrolled)
;;; 2. cuccaro-add/sub-low-to-ext-clean! with cin
;;; 3. unload (same op-stream self-inverse)
;;;
;;; HEAD's `borrow_cin: Option<QubitId>` switches between caller-
;;; supplied vs fresh-alloc cin. Lumbda is caller-allocated throughout;
;;; cin-reg + cin-idx are mandatory caller-supplied parameters. The
;;; six HEAD names collapse to a smaller surface in lumbda but we keep
;;; all six for ABI parity — callers may want to name the "borrow"
;;; variant explicitly even though the wire pattern is identical.
;;;
;;; Caller responsibility:
;;; - acc-ext-reg width >= n+1 (n data bits + 1 ext carry bit)
;;; - ca-reg width >= n (clean |0> on entry; restored on exit)
;;; - cin-reg[cin-idx] = |0> on entry; restored on exit
;;; - ctrl-reg[ctrl-idx] (controlled variants) — read-only
(define (add-nbit-const-extcarry-clean!
c acc-ext-reg n k ca-reg cin-reg cin-idx)
"Port of HEAD add_nbit_const_extcarry_clean (const_arith.rs:239).
acc-ext-reg := (acc-ext-reg + k) mod 2^(n+1), carry into top bit."
(load-const! c ca-reg n k)
(cuccaro-add-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx)
(unload-const! c ca-reg n k))
(define (add-nbit-const-extcarry-clean-with-cin!
c acc-ext-reg n k ca-reg cin-reg cin-idx)
"Port of HEAD add_nbit_const_extcarry_clean_with_cin
(const_arith.rs:251). Wire-identical to the non-with-cin variant
in lumbda since cin is always caller-supplied; preserves HEAD's
ABI name for callers that explicitly borrow cin from a live-idle
lane (round84-lowq mid-sub uses this naming)."
(add-nbit-const-extcarry-clean!
c acc-ext-reg n k ca-reg cin-reg cin-idx))
(define (sub-nbit-const-extcarry-clean!
c acc-ext-reg n k ca-reg cin-reg cin-idx)
"Port of HEAD sub_nbit_const_extcarry_clean (const_arith.rs:274).
acc-ext-reg := (acc-ext-reg - k) mod 2^(n+1), borrow into top bit."
(load-const! c ca-reg n k)
(cuccaro-sub-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx)
(unload-const! c ca-reg n k))
(define (cadd-nbit-const-extcarry-clean!
c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx)
"Port of HEAD cadd_nbit_const_extcarry_clean (const_arith.rs:289).
acc-ext-reg += (ctrl ? k : 0), carry into top bit. Drop-in for
cadd-nbit-const. Constant loaded via CX-from-ctrl so the
unconditional clean adder realizes the controlled add."
(cload-const! c ctrl-reg ctrl-idx ca-reg n k)
(cuccaro-add-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx)
(cunload-const! c ctrl-reg ctrl-idx ca-reg n k))
(define (csub-nbit-const-extcarry-clean!
c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx)
"Port of HEAD csub_nbit_const_extcarry_clean (const_arith.rs:317).
acc-ext-reg -= (ctrl ? k : 0), borrow into top bit."
(cload-const! c ctrl-reg ctrl-idx ca-reg n k)
(cuccaro-sub-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx)
(cunload-const! c ctrl-reg ctrl-idx ca-reg n k))
(define (csub-nbit-const-extcarry-clean-with-cin!
c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx)
"Port of HEAD csub_nbit_const_extcarry_clean_with_cin
(const_arith.rs:331). Wire-identical to csub-nbit-const-extcarry-
clean! in lumbda; ABI alias for explicit-borrow callers (the
peak-binding round84-lowq mid-sub borrows c_in from idle a_ovf
lane to drop peak 1308 -> 1307)."
(csub-nbit-const-extcarry-clean!
c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx))
;;; ── add/sub of classical constant ──────────────────────────────
(define (add-const! c acc-reg n k cin-reg cin-idx tmp-reg)
"acc := (acc + k) mod 2^n. tmp must be a width-n register at |0>."
(let ((kk (modulo k (expt 2 n))))
(load-const! c tmp-reg n kk)
(cuccaro-add! c tmp-reg acc-reg cin-reg cin-idx n)
(unload-const! c tmp-reg n kk)))
(define (csub-const! c acc-reg n k ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg)
"acc -= (ctrl ? k : 0) mod 2^n. Dispatches to direct sparse path when
*cadd-direct-trunc-fast* on; else cload + cuccaro-sub + cunload."
(let ((kk (modulo k (expt 2 n))))
(cond
((and *cadd-direct-trunc-fast* (> n 1) (> kk 0))
(csub-nbit-const-direct-trunc-fast!
c acc-reg n kk ctrl-reg ctrl-idx tmp-reg
*cadd-direct-window* (cdtf-alloc-bit-base! n)))
(else
(cload-const! c ctrl-reg ctrl-idx tmp-reg n kk)
;; sub = inverse of add. cuccaro-add (a, acc) is a bijection; we
;; manually invert by emitting the gates in reverse. Implemented as
;; cuccaro-sub! below.
(cuccaro-sub! c tmp-reg acc-reg cin-reg cin-idx n)
(cunload-const! c ctrl-reg ctrl-idx tmp-reg n kk)))))
;;; ── Cuccaro sub (inverse of cuccaro-add) ───────────────────────
(define (cuccaro-sub! c a-reg acc-reg cin-reg cin-idx n)
"acc := (acc - a) mod 2^n. Inverse of cuccaro-add gate-by-gate."
(cond
((= n 0) #t)
((= n 1)
(gate-cx! c a-reg 0 acc-reg 0)
(gate-cx! c cin-reg cin-idx acc-reg 0))
(else
;; Inverse of cuccaro-add:
;; inv-uma at i=0
;; inv-uma for i in 1..n-2
;; inv of final CX pair (cx is its own inverse, so same gates reversed)
;; inv-maj for i in n-2..1 (descending in fwd; so ascending in inv)
;; inv-maj at top (c-in,acc[0],a[0])
;;
;; UMA(x,y,w): (ccx x y w)(cx w x)(cx x y)
;; inv-UMA = (cx x y)(cx w x)(ccx x y w)
;; MAJ(x,y,w): (cx w y)(cx w x)(ccx x y w)
;; inv-MAJ = (ccx x y w)(cx w x)(cx w y)
;;
;; Walking forward gates in reverse order:
;; final uma(cin,acc[0],a[0]) -> inv-uma at start
;; for i in 1..n-2 (forward order in inverse: that's the rev loop)
;; uma(a[i-1], acc[i], a[i])
;; reverse of "cx a[n-1] acc[n-1]; cx a[n-2] acc[n-1]" is same two CX
;; reverse of MAJ sweep
(inv-uma! c cin-reg cin-idx acc-reg 0 a-reg 0)
(let loop ((i 1))
(when (< i (- n 1))
(inv-uma! c a-reg (- i 1) acc-reg i a-reg i)
(loop (+ i 1))))
(gate-cx! c a-reg (- n 1) acc-reg (- n 1))
(gate-cx! c a-reg (- n 2) acc-reg (- n 1))
(let loop ((i (- n 2)))
(when (>= i 1)
(inv-maj! c a-reg (- i 1) acc-reg i a-reg i)
(loop (- i 1))))
(inv-maj! c cin-reg cin-idx acc-reg 0 a-reg 0))))
(define (inv-uma! c x-reg x-idx y-reg y-idx w-reg w-idx)
"Inverse of uma!: (cx x y) (cx w x) (ccx x y w)."
(gate-cx! c x-reg x-idx y-reg y-idx)
(gate-cx! c w-reg w-idx x-reg x-idx)
(gate-ccx! c x-reg x-idx y-reg y-idx w-reg w-idx))
(define (inv-maj! c x-reg x-idx y-reg y-idx w-reg w-idx)
"Inverse of maj!: (ccx x y w) (cx w x) (cx w y)."
(gate-ccx! c x-reg x-idx y-reg y-idx w-reg w-idx)
(gate-cx! c w-reg w-idx x-reg x-idx)
(gate-cx! c w-reg w-idx y-reg y-idx))
;;; ── n-bit comparison: flag := flag XOR (u < v) ─────────────────
(define (cmp-lt-into! c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx)
"flag ^= (u < v). u and v are width-n quantum registers; restored.
cin starts |0> ends |0>."
;; Negate u
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
;; Forward MAJ sweep — n MAJs (includes the top one)
(maj! c cin-reg cin-idx v-reg 0 u-reg 0)
(let loop ((i 1))
(when (< i n)
(maj! c u-reg (- i 1) v-reg i u-reg i)
(loop (+ i 1))))
;; CX top -> flag
(gate-cx! c u-reg (- n 1) flag-reg flag-idx)
;; Inverse MAJ sweep
(let loop ((i (- n 1)))
(when (>= i 1)
(inv-maj! c u-reg (- i 1) v-reg i u-reg i)
(loop (- i 1))))
(inv-maj! c cin-reg cin-idx v-reg 0 u-reg 0)
;; Un-negate u
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))))
;;; cmp-lt-into-fast! — HEAD's cmp_lt_into_fast (mod.rs:3643-3693)
;;; HMR-uncompute variant of cmp-lt-into!. Same flag semantics but
;;; carries lane borrowed from caller + HMR backward sweep saves n
;;; Toffoli per call.
(define (cmp-lt-into-fast! c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx
carries-reg carries-offset bit-base)
"flag ^= (u < v). Same semantics as cmp-lt-into! but with HMR carry
uncompute. carries-reg[carries-offset..carries-offset+n-1] must be
|0> on entry; HMR returns them to |0> on exit.
bit-base..bit-base+n-1 used for classical bits."
(cond
((= n 0) #t)
(else
;; Negate u
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
;; Forward sweep — n MAJ-style with explicit carries
(gate-cx! c u-reg 0 v-reg 0)
(gate-cx! c u-reg 0 cin-reg cin-idx)
(gate-ccx! c cin-reg cin-idx v-reg 0 carries-reg carries-offset)
(gate-cx! c carries-reg carries-offset u-reg 0)
(let loop ((i 1))
(when (< i n)
(gate-cx! c u-reg i v-reg i)
(gate-cx! c u-reg i u-reg (- i 1))
(gate-ccx! c u-reg (- i 1) v-reg i carries-reg (+ carries-offset i))
(gate-cx! c carries-reg (+ carries-offset i) u-reg i)
(loop (+ i 1))))
;; CX top carry -> flag
(gate-cx! c u-reg (- n 1) flag-reg flag-idx)
;; Backward HMR uncompute sweep
(let loop-back ((i (- n 1)))
(when (>= i 1)
(gate-cx! c carries-reg (+ carries-offset i) u-reg i)
(gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i))
(gate-push-cond! c (+ bit-base i))
(gate-cz! c u-reg (- i 1) v-reg i)
(gate-pop-cond! c)
(gate-cx! c u-reg i u-reg (- i 1))
(gate-cx! c u-reg i v-reg i)
(loop-back (- i 1))))
;; Step 0 backward
(gate-cx! c carries-reg carries-offset u-reg 0)
(gate-hmr! c carries-reg carries-offset bit-base)
(gate-push-cond! c bit-base)
(gate-cz! c cin-reg cin-idx v-reg 0)
(gate-pop-cond! c)
(gate-cx! c u-reg 0 cin-reg cin-idx)
(gate-cx! c u-reg 0 v-reg 0)
;; Un-negate u
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))))))
;;; ── ccx-cmp-lt-into-fast! / cmp-lt-into-fast-with-cin! / phase-conditioned variants
;;;
;;; HEAD compare.rs:55,108,330,357. Closes AUDIT §7 rows 184-185 + 186-187
;;; (compare.rs no-prefix-targets siblings).
;;;
;;; ──── cmp-lt-into-fast-with-cin! — ABI alias ────
;;; HEAD's cmp_lt_into_fast_with_cin (compare.rs:55) is wire-identical
;;; to cmp_lt_into_fast except c_in is caller-supplied instead of
;;; freshly-allocated. Lumbda's cmp-lt-into-fast! is ALREADY the
;;; with-cin form (caller passes cin-reg + cin-idx). This alias names
;;; the variant for callers that explicitly borrow c_in from a live-
;;; idle lane.
(define (cmp-lt-into-fast-with-cin!
c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx
carries-reg carries-offset bit-base)
"Port of HEAD cmp_lt_into_fast_with_cin (compare.rs:55). Wire-
identical to cmp-lt-into-fast! in lumbda; ABI alias for explicit-
borrow callers."
(cmp-lt-into-fast!
c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx
carries-reg carries-offset bit-base))
;;; ──── ccx-cmp-lt-into-fast! — without prefix-targets ────
;;; HEAD compare.rs:108. Identical to cmp_lt_into_fast but replaces
;;; cx(u[n-1], flag) with ccx(ctrl, u[n-1], target). All other gates
;;; mirror cmp-lt-into-fast! verbatim.
(define (ccx-cmp-lt-into-fast!
c u-reg v-reg n ctrl-reg ctrl-idx target-reg target-idx
cin-reg cin-idx carries-reg carries-offset bit-base)
"Port of HEAD ccx_cmp_lt_into_fast (compare.rs:108). target ^=
(ctrl AND (u < v)). Same Gidney measurement-UMA pattern as
cmp-lt-into-fast! with the middle CX replaced by CCX."
(cond
((= n 0) #t)
(else
;; Negate u
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
;; Forward sweep
(gate-cx! c u-reg 0 v-reg 0)
(gate-cx! c u-reg 0 cin-reg cin-idx)
(gate-ccx! c cin-reg cin-idx v-reg 0 carries-reg carries-offset)
(gate-cx! c carries-reg carries-offset u-reg 0)
(let loop ((i 1))
(when (< i n)
(gate-cx! c u-reg i v-reg i)
(gate-cx! c u-reg i u-reg (- i 1))
(gate-ccx! c u-reg (- i 1) v-reg i carries-reg (+ carries-offset i))
(gate-cx! c carries-reg (+ carries-offset i) u-reg i)
(loop (+ i 1))))
;; CCX top carry -> target (only diff vs cmp-lt-into-fast!)
(gate-ccx! c ctrl-reg ctrl-idx u-reg (- n 1) target-reg target-idx)
;; Backward HMR uncompute sweep
(let loop-back ((i (- n 1)))
(when (>= i 1)
(gate-cx! c carries-reg (+ carries-offset i) u-reg i)
(gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i))
(gate-push-cond! c (+ bit-base i))
(gate-cz! c u-reg (- i 1) v-reg i)
(gate-pop-cond! c)
(gate-cx! c u-reg i u-reg (- i 1))
(gate-cx! c u-reg i v-reg i)
(loop-back (- i 1))))
(gate-cx! c carries-reg carries-offset u-reg 0)
(gate-hmr! c carries-reg carries-offset bit-base)
(gate-push-cond! c bit-base)
(gate-cz! c cin-reg cin-idx v-reg 0)
(gate-pop-cond! c)
(gate-cx! c u-reg 0 cin-reg cin-idx)
(gate-cx! c u-reg 0 v-reg 0)
;; Un-negate u
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))))))
;;; ──── cmp-lt-phase-conditioned! / -borrowed-carries! ────
;;; HEAD compare.rs:357 / 330. Phase-conditioned comparator variants.
;;; Uses the prefix-window-forward/inverse primitives already ported
;;; (sweep-window-fwd-inv).
;;;
;;; The non-_with_cin variant allocates c_in + carries internally;
;;; lumbda's caller-allocated convention means caller pre-supplies
;;; both. The borrowed-carries variant takes carries from caller.
(define (cmp-lt-phase-conditioned!
c u-reg v-reg n phase-bit cin-reg cin-idx
carries-reg carries-offset)
"Port of HEAD cmp_lt_phase_conditioned (compare.rs:357). Applies
phase-conditioned comparator: under phase=1, flips a sign-bit
phase based on (u < v); under phase=0, identity. Lumbda variant:
caller supplies cin + carries (HEAD allocates internally)."
(gate-push-cond! c phase-bit)
;; Negate u
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
;; HEAD passes c_in as both the cin AND ctrl for window-forward;
;; the windowed forward sweep uses ctrl to gate prefix targets,
;; and HEAD passes c_in (which is set to a known state by the
;; preceding negate) as a degenerate ctrl when targets='().
(cmp-lt-fast-prefix-window-forward!
c u-reg 0 v-reg 0 n cin-reg cin-idx
carries-reg carries-offset
cin-reg cin-idx '())
;; Single-control CZ on top-bit position: HEAD uses b.cz(u[n-1], u[n-1])
;; which classically degenerates to a sign-bit phase. Lumbda gate-cz!
;; with same reg+idx is the same op.
(gate-cz! c u-reg (- n 1) u-reg (- n 1))
(cmp-lt-fast-prefix-window-inverse!
c u-reg 0 v-reg 0 n cin-reg cin-idx
carries-reg carries-offset)
;; Un-negate u
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
(gate-pop-cond! c))
(define (cmp-lt-phase-conditioned-borrowed-carries!
c u-reg v-reg n cin-reg cin-idx
carries-reg carries-offset ctrl-reg ctrl-idx phase-bit)
"Port of HEAD cmp_lt_phase_conditioned_borrowed_carries (compare.rs:330).
Same as cmp-lt-phase-conditioned! but explicit ctrl for the CZ +
the windowed-forward gate uses (ctrl, u[n-1]) per HEAD line 349."
(gate-push-cond! c phase-bit)
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
(cmp-lt-fast-prefix-window-forward!
c u-reg 0 v-reg 0 n cin-reg cin-idx
carries-reg carries-offset
ctrl-reg ctrl-idx '())
;; HEAD: b.cz(ctrl, u[n-1])
(gate-cz! c ctrl-reg ctrl-idx u-reg (- n 1))
(cmp-lt-fast-prefix-window-inverse!
c u-reg 0 v-reg 0 n cin-reg cin-idx
carries-reg carries-offset)
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
(gate-pop-cond! c))
;;; ── ccx-cmp-lt-into-fast-prefix-targets! ──────────────────────────
;;;
;;; Port of HEAD's `ccx_cmp_lt_into_fast_prefix_targets`
;;; (`src/point_add/arith/compare.rs:161-232`, commit 2dcf00d). Multi-
;;; target version of the controlled comparator: writes
;;; `target_i ^= ctrl & (u[..n_i] < v[..n_i])` for every (target_i,
;;; n_i) in `targets`. Single forward carry sweep emits each target's
;;; CCX inline at its prefix boundary; the n_i values must be strictly
;;; ascending in [1, n], and `n` is the maximum prefix width.
;;;
;;; Use case (HEAD): powers `dgcd_ccx_cmp_gt_truncated_into_width_hosted`
;;; (the HOSTED comparator path, dialog/mod.rs:83). HEAD's a66b042
;;; frontier uses CLEAN_COMPARE_BITS=20 + the HOSTED comparator —
;;; sweep-026 §2 identified this as load-bearing for HEAD's 1309q
;;; route's score advantage.
;;;
;;; Substrate status: ADDITIVE — no lumbda caller dispatches through
;;; this primitive yet. Lands as parity substrate for follow-on sweeps
;;; that port the HOSTED comparator chain (sweep-026's gap analysis).
;;;
;;; Signature mirrors HEAD's argument order:
;;; c — circuit handle.
;;; u-reg v-reg — quantum registers of width >= n. Compared bitwise.
;;; n — maximum prefix width (= largest target prefix-width).
;;; ctrl-reg ctrl-idx — control qubit; comparator only writes when ctrl is |1>.
;;; targets — list of (target-reg target-idx prefix-width) triples.
;;; Strictly ascending prefix-widths, each in [1, n].
;;; Empty list is a clean no-op (HEAD line 168-170).
;;; carries-reg carries-offset — borrowed |0>-on-entry carries lane
;;; of width >= n. Returned to |0> on exit via HMR.
;;; cin-reg cin-idx — borrowed |0> ancilla; restored on exit.
;;; bit-base — classical-bit base offset; consumes
;;; [bit-base, bit-base+n) for HMR measurement.
;;;
;;; Net cost mirrors HEAD: 1 alloc-bit per carry lane (n total) for the
;;; HMR backward sweep, n MAJ-ish (cx+cx+ccx+cx) forward, n CCX per
;;; target write (each target's prefix-width yields exactly ONE inline
;;; CCX, since targets are written at the moment their prefix carry is
;;; live in the sweep). Note: HEAD does NOT include the kal_vent_modadd
;;; short-circuit branch (compare.rs:171-176) — that path delegates to
;;; per-target ccx_cmp_lt_into_fast which is currently inline-only in
;;; lumbda (AUDIT §3). Adding it later is additive + flag-gated.
(define (ccx-cmp-lt-into-fast-prefix-targets!
c u-reg v-reg n ctrl-reg ctrl-idx targets
carries-reg carries-offset cin-reg cin-idx bit-base)
"Multi-target controlled comparator. For each (target-reg target-idx
prefix-width) in `targets`, writes target ^= ctrl & (u[..prefix-width]
< v[..prefix-width]). Targets MUST have strictly ascending
prefix-widths each in [1, n]. Returns carries-reg + cin-reg to |0>
via HMR uncompute."
(cond
;; Clean no-op on empty target list (HEAD compare.rs:168-170).
((null? targets) #t)
((= n 0) #t)
(else
;; Step 1: negate u. Mirrors HEAD's `for &q in u { b.x(q); }`.
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
;; Step 2: forward carry sweep with inline target writes.
;; First slot (i=0) mirrors HEAD compare.rs:191-199.
(gate-cx! c u-reg 0 v-reg 0)
(gate-cx! c u-reg 0 cin-reg cin-idx)
(gate-ccx! c cin-reg cin-idx v-reg 0 carries-reg carries-offset)
(gate-cx! c carries-reg carries-offset u-reg 0)
;; Walk targets in step with the forward sweep. `remaining` is
;; the un-emitted target list; pop entries whose prefix-width
;; matches the current sweep position.
(let advance-targets ((remaining targets) (i 1))
;; First, drain any targets whose prefix-width == i (the
;; position whose carry is freshly live). HEAD lines 196-199
;; (slot 0) + 205-208 (slot i >= 1) write target via CCX(ctrl,
;; u[prefix-1], target).
(cond
((and (not (null? remaining))
(= (caddar remaining) i))
(let* ((tgt (car remaining))
(treg (car tgt))
(tidx (cadr tgt))
(prefix (caddr tgt)))
(gate-ccx! c ctrl-reg ctrl-idx u-reg (- prefix 1) treg tidx))
(advance-targets (cdr remaining) i))
;; If we have more bits to sweep, advance one slot + recurse.
((< i n)
(gate-cx! c u-reg i v-reg i)
(gate-cx! c u-reg i u-reg (- i 1))
(gate-ccx! c u-reg (- i 1) v-reg i carries-reg (+ carries-offset i))
(gate-cx! c carries-reg (+ carries-offset i) u-reg i)
(advance-targets remaining (+ i 1)))
;; Sweep done. Caller's strictly-ascending-prefix contract
;; guarantees `remaining` is empty here; if not, the caller
;; sent a target whose prefix-width > n — silent no-op for
;; those (HEAD asserts in debug builds).
(else #t)))
;; Step 3: backward HMR uncompute. Identical shape to
;; cmp-lt-into-fast!'s backward sweep (HEAD compare.rs:212-225).
(let loop-back ((i (- n 1)))
(when (>= i 1)
(gate-cx! c carries-reg (+ carries-offset i) u-reg i)
(gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i))
(gate-push-cond! c (+ bit-base i))
(gate-cz! c u-reg (- i 1) v-reg i)
(gate-pop-cond! c)
(gate-cx! c u-reg i u-reg (- i 1))
(gate-cx! c u-reg i v-reg i)
(loop-back (- i 1))))
;; Step 0 backward.
(gate-cx! c carries-reg carries-offset u-reg 0)
(gate-hmr! c carries-reg carries-offset bit-base)
(gate-push-cond! c bit-base)
(gate-cz! c cin-reg cin-idx v-reg 0)
(gate-pop-cond! c)
(gate-cx! c u-reg 0 cin-reg cin-idx)
(gate-cx! c u-reg 0 v-reg 0)
;; Un-negate u.
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))))))
;;; ── ccx-cmp-lt-into-fast-borrowed-carries! ────────────────────────
;;;
;;; Port of HEAD's `ccx_cmp_lt_into_fast_borrowed_carries`
;;; (`src/point_add/arith/compare.rs:561-612`, commit 2dcf00d). Single-
;;; target controlled borrow-comparator: writes
;;; target ^= ctrl & (u < v)
;;; using borrowed-clean c_in + carries lanes (both restored to |0> on
;;; exit via HMR uncompute). HEAD's docstring at compare.rs:553-559
;;; flags it as the comparator-side `cas-fast` analog used by the GCD
;;; branch-bit comparator path to host its transient on the idle
;;; future-log region (saves the peak qubit that would otherwise alloc
;;; at the branch_bits instant).
;;;
;;; Implementation: thin wrapper over `ccx-cmp-lt-into-fast-prefix-targets!`
;;; with a single-element targets list = `((target-reg target-idx n))`.
;;; HEAD's standalone-function form (compare.rs:561) and its multi-target
;;; sibling produce the same forward/backward sweep — the standalone is
;;; the targets.len()==1 case at the full-width prefix. Wrapping over the
;;; just-ported prefix-targets! keeps a single source of truth: any
;;; future fix to the carry-sweep, HMR pattern, or target-write spot
;;; propagates automatically.
;;;
;;; Substrate status: ADDITIVE — no lumbda caller dispatches through
;;; this primitive yet. Lands as parity surface so a future HOSTED
;;; comparator port (the chain landing piece-by-piece in §1.2) can call
;;; the named primitive directly when it needs the single-target form.
(define (ccx-cmp-lt-into-fast-borrowed-carries!
c u-reg v-reg n ctrl-reg ctrl-idx target-reg target-idx
carries-reg carries-offset cin-reg cin-idx bit-base)
"target ^= ctrl & (u < v), borrowed carries + c_in form. See header
comment. n=0 is a clean no-op (mirrors prefix-targets!'s n=0 path)."
(ccx-cmp-lt-into-fast-prefix-targets!
c u-reg v-reg n ctrl-reg ctrl-idx
(list (list target-reg target-idx n))
carries-reg carries-offset cin-reg cin-idx bit-base))
;;; ── ccx-cmp-lt-into-fast-borrowed-carries-offset! ─────────────────
;;;
;;; Offset-indexed variant of `ccx-cmp-lt-into-fast-borrowed-carries!`
;;; — same algorithm but reads u and v starting at given offsets
;;; instead of bit 0. Mirrors HEAD compare.rs:561 the way our
;;; cmp-lt-into-fast-offset! mirrors cmp-lt-into-fast! (one offset
;;; parameter per register).
;;;
;;; Use case: HEAD's HOSTED comparator (dialog/mod.rs:83) slices its
;;; input via `&u[start..]; &v[start..]` where start = active_width -
;;; compare_bits. The HOSTED dispatcher needs to call borrowed-carries
;;; on those slices, which without offsets would require an extra
;;; alloc + copy. The offset variant lets HOSTED call directly with
;;; (u-reg, start, ...) avoiding the per-call ancilla.
;;;
;;; Substrate status: ADDITIVE. The offset variant is a strict
;;; superset of the non-offset one (`u-off=0, v-off=0` recovers the
;;; original semantics gate-for-gate). Existing `ccx-cmp-lt-into-fast-
;;; borrowed-carries!` callers (none yet) remain untouched.
;;;
;;; Implementation: forward sweep mirrors HEAD compare.rs:563-595 with
;;; offsets threaded through every gate-cx! / gate-ccx! call; backward
;;; HMR uncompute mirrors compare.rs:597-611 similarly. Both halves
;;; identical to the non-offset variant when u-off=v-off=0.
(define (ccx-cmp-lt-into-fast-borrowed-carries-offset!
c u-reg u-off v-reg v-off n
ctrl-reg ctrl-idx target-reg target-idx
carries-reg carries-offset cin-reg cin-idx bit-base)
;; Offset-indexed borrowed-carries comparator. n=0 is a no-op.
;; All offsets in [0, register-width-n]; caller guarantees.
(cond
((= n 0) #t)
(else
;; Negate u slice (in place).
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))
;; Forward sweep with target write at the n-th boundary.
(gate-cx! c u-reg u-off v-reg v-off)
(gate-cx! c u-reg u-off cin-reg cin-idx)
(gate-ccx! c cin-reg cin-idx v-reg v-off carries-reg carries-offset)
(gate-cx! c carries-reg carries-offset u-reg u-off)
(cond
((= n 1)
;; Single-bit: write target at prefix=1.
(gate-ccx! c ctrl-reg ctrl-idx u-reg u-off target-reg target-idx))
(else
(let loop ((i 1))
(when (< i n)
(gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i))
(gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
(gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)
carries-reg (+ carries-offset i))
(gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i))
(loop (+ i 1))))
;; Target write at prefix=n: ccx(ctrl, u[u-off + n - 1], target).
(gate-ccx! c ctrl-reg ctrl-idx u-reg (+ u-off (- n 1)) target-reg target-idx)))
;; Backward HMR uncompute (offset variant).
(let loop-back ((i (- n 1)))
(when (>= i 1)
(gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i))
(gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i))
(gate-push-cond! c (+ bit-base i))
(gate-cz! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i))
(gate-pop-cond! c)
(gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
(gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i))
(loop-back (- i 1))))
(gate-cx! c carries-reg carries-offset u-reg u-off)
(gate-hmr! c carries-reg carries-offset bit-base)
(gate-push-cond! c bit-base)
(gate-cz! c cin-reg cin-idx v-reg v-off)
(gate-pop-cond! c)
(gate-cx! c u-reg u-off cin-reg cin-idx)
(gate-cx! c u-reg u-off v-reg v-off)
;; Un-negate u slice.
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1)))))))
;;; ── cmp-lt-fast-prefix-window-forward! + -inverse! ───────────────
;;;
;;; Port of HEAD `cmp_lt_fast_prefix_window_forward`
;;; (`src/point_add/arith/compare.rs:234-270`, commit 2dcf00d) +
;;; `cmp_lt_fast_prefix_window_inverse` (`compare.rs:272-298`).
;;;
;;; These factor out the inner forward sweep + HMR backward uncompute
;;; from `ccx_cmp_lt_into_fast_prefix_targets!`. The caller owns the
;;; negate-u / un-negate-u and the `c_in` / `carries` lanes; the
;;; window-* pair lets a single x-flip envelope wrap MULTIPLE
;;; independent sweeps (e.g. `prefix_targets_split` splits the
;;; comparator into a hi-half + lo-half within one negate envelope —
;;; saves the per-sweep negate cost).
;;;
;;; Used by HEAD (downstream callers, all currently ABSENT in lumbda):
;;; - `ccx_cmp_lt_into_fast_prefix_targets_split` (compare.rs:330)
;;; - `cmp_lt_phase_conditioned` (compare.rs:303)
;;; - `cmp_lt_phase_conditioned_with_cin`
;;; - `cmp_lt_phase_conditioned_borrowed_carries`
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; either primitive yet. Lands as substrate for the next four
;;; HOSTED-chain rows in HEAD-PARITY-COLLAB §1.2.
(define (cmp-lt-fast-prefix-window-forward!
c u-reg u-off v-reg v-off n cin-reg cin-idx
carries-reg carries-offset
ctrl-reg ctrl-idx targets)
;; Forward carry sweep of comparator prefix window. Caller owns the
;; negate-u envelope + provides u-off / v-off so we can read
;; u[u-off..u-off+n] / v[v-off..v-off+n] (lumbda registers are
;; flat indexed -- this is the slice analog).
;;
;; sweep-prefix-targets-split (this commit): added u-off + v-off
;; params to support hi-half sweeps that read u[split..n] not just
;; u[0..n]. Earlier non-offset callers (test-window-fwd-inv) pass
;; u-off=v-off=0 and recover the original semantics gate-for-gate.
(cond
((= n 0) #t)
(else
(gate-cx! c u-reg u-off v-reg v-off)
(gate-cx! c u-reg u-off cin-reg cin-idx)
(gate-ccx! c cin-reg cin-idx v-reg v-off carries-reg carries-offset)
(gate-cx! c carries-reg carries-offset u-reg u-off)
(let advance ((remaining targets) (i 1))
(cond
;; Drain targets at current prefix boundary i. Targets carry
;; LOCAL prefix-widths (1..n); we write at u[u-off + prefix - 1].
((and (not (null? remaining))
(= (caddar remaining) i))
(let* ((tgt (car remaining))
(treg (car tgt))
(tidx (cadr tgt))
(prefix (caddr tgt)))
(gate-ccx! c ctrl-reg ctrl-idx u-reg (+ u-off (- prefix 1)) treg tidx))
(advance (cdr remaining) i))
((< i n)
(gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i))
(gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
(gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)
carries-reg (+ carries-offset i))
(gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i))
(advance remaining (+ i 1)))
(else #t))))))
(define (cmp-lt-fast-prefix-window-inverse!
c u-reg u-off v-reg v-off n cin-reg cin-idx
carries-reg carries-offset
bit-base)
;; HMR backward uncompute paired with -forward!. Returns carries-reg
;; + cin-reg to |0> via measurement-conditioned CZ. Offset-aware
;; (sweep-prefix-targets-split this commit).
(cond
((= n 0) #t)
(else
(let loop-back ((i (- n 1)))
(when (>= i 1)
(gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i))
(gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i))
(gate-push-cond! c (+ bit-base i))
(gate-cz! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i))
(gate-pop-cond! c)
(gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
(gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i))
(loop-back (- i 1))))
(gate-cx! c carries-reg carries-offset u-reg u-off)
(gate-hmr! c carries-reg carries-offset bit-base)
(gate-push-cond! c bit-base)
(gate-cz! c cin-reg cin-idx v-reg v-off)
(gate-pop-cond! c)
(gate-cx! c u-reg u-off cin-reg cin-idx)
(gate-cx! c u-reg u-off v-reg v-off))))
;;; ── ccx-cmp-lt-into-fast-prefix-targets-split! ───────────────────
;;;
;;; Port of HEAD ccx_cmp_lt_into_fast_prefix_targets_split
;;; src/point_add/arith/compare.rs:384-516, commit 2dcf00d. Closes
;;; the last ABSENT row in the HOSTED comparator chain section 1.2.
;;;
;;; What HEAD does: splits a multi-prefix comparator into hi-half
;;; (bits [split..n]) and lo-half (bits [0..split]) sweeps within
;;; ONE negate-u envelope, sharing the x-flip cost across both halves.
;;; Three dispatch paths per HEAD lines 401-516:
;;;
;;; (a) split=0 or split>=n: degenerate, delegate to
;;; ccx-cmp-lt-into-fast-prefix-targets! verbatim.
;;;
;;; (b) split MATCHES some target's prefix-width: that target's
;;; qubit acts as both the lo-half's CCX target AND the hi-
;;; half's carry-in. Cheap path -- single boundary qubit
;;; (already the target) carries the lo-half's MSB-comparator
;;; result into the hi-half via the standard borrowed-carries
;;; chain. Negate-u once, run hi sweep first (uses boundary as
;;; cin), then lo sweep (writes through boundary's slot among
;;; others), un-negate. HEAD lines 406-451.
;;;
;;; (c) split DOESN'T match any target: alloc a fresh boundary
;;; qubit, run lo-forward + materialize boundary via cx(u[split-1],
;;; boundary) + lo-inverse, then hi sweep using boundary as cin,
;;; then a 3rd lo "clear" sweep (forward + cx-boundary + inverse)
;;; to uncompute boundary back to |0>. HEAD lines 453-516.
;;;
;;; Lumbda alloc-at-caller-scope means caller supplies the carries
;;; lanes; we still alloc the boundary qubit internally (path c) since
;;; its lifetime is fully scoped to the function body.
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; this primitive yet. Closes section 1.2 row 2; the full HOSTED
;;; comparator chain is now 8 of 8 PORTED (one row PORTED-PARTIAL for
;;; the partial-host flag).
(define (ccx-cmp-lt-into-fast-prefix-targets-split!
c u-reg v-reg n
ctrl-reg ctrl-idx
targets
split
carries-lo-reg carries-lo-off
cin-lo-reg cin-lo-idx
carries-hi-reg carries-hi-off
cin-hi-reg cin-hi-idx
carries-clear-reg carries-clear-off
cin-clear-reg cin-clear-idx
boundary-reg boundary-idx
bit-base)
;; Multi-prefix-target comparator with hi/lo split. Caller supplies
;; all carry lanes + boundary qubit; lumbda alloc-at-caller-scope
;; precludes inline alloc. Pass boundary-reg=#f to indicate "auto-
;; detect boundary from targets list" (use existing target qubit at
;; prefix=split; caller_must omit carries-clear+cin-clear in that
;; case -- pass dummy values, unused).
;;
;; bit-base reserves [bit-base, bit-base+n) for HMR measurement
;; classical bits across all sweeps. We slot the three sweeps as:
;; hi sweep: bit-base + 0 .. bit-base + (n-split)
;; lo sweep: bit-base + (n-split) .. bit-base + n
;; clear sweep (path c only): bit-base + n .. bit-base + n + split
(cond
;; Path (a): degenerate split -> delegate.
((or (= split 0) (>= split n))
(ccx-cmp-lt-into-fast-prefix-targets!
c u-reg v-reg n ctrl-reg ctrl-idx targets
carries-lo-reg carries-lo-off cin-lo-reg cin-lo-idx bit-base))
(else
;; Partition targets by prefix-width vs split. Each target =
;; (target-reg target-idx prefix-width). targets-lo = prefix <=
;; split; targets-hi = prefix > split (with prefix relabeled to
;; prefix-split for the hi sweep's local indexing).
(let* ((targets-lo
(let loop ((rest targets) (acc '()))
(cond
((null? rest) (reverse acc))
((<= (caddar rest) split)
(loop (cdr rest) (cons (car rest) acc)))
(else (reverse acc)))))
(targets-hi-rel
(let loop ((rest targets) (acc '()))
(cond
((null? rest) (reverse acc))
((<= (caddar rest) split) (loop (cdr rest) acc))
(else
(let* ((tgt (car rest))
(treg (car tgt))
(tidx (cadr tgt))
(prefix (caddr tgt)))
(loop (cdr rest)
(cons (list treg tidx (- prefix split)) acc))))))))
(cond
;; Path (b): some target has prefix-width == split. That
;; target IS the boundary qubit; no fresh alloc needed.
((let loop ((rest targets))
(cond
((null? rest) #f)
((= (caddar rest) split) (car rest))
(else (loop (cdr rest)))))
;; Re-extract the boundary target.
(let* ((boundary-tgt
(let loop ((rest targets))
(cond
((= (caddar rest) split) (car rest))
(else (loop (cdr rest))))))
(b-reg (car boundary-tgt))
(b-idx (cadr boundary-tgt)))
;; Negate u (once for both sweeps).
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
;; Hi sweep over u[split..n] using boundary as cin.
;; Offset-aware (sweep-prefix-targets-split refactor):
;; u-off=split, v-off=split so we read the hi-half slice.
(let ((hi-len (- n split)))
(cmp-lt-fast-prefix-window-forward!
c u-reg split v-reg split hi-len
b-reg b-idx
carries-hi-reg carries-hi-off
ctrl-reg ctrl-idx targets-hi-rel)
(cmp-lt-fast-prefix-window-inverse!
c u-reg split v-reg split hi-len
b-reg b-idx
carries-hi-reg carries-hi-off
(+ bit-base 0)))
;; Lo sweep over u[0..split] using fresh cin-lo.
(cmp-lt-fast-prefix-window-forward!
c u-reg 0 v-reg 0 split
cin-lo-reg cin-lo-idx
carries-lo-reg carries-lo-off
ctrl-reg ctrl-idx targets-lo)
(cmp-lt-fast-prefix-window-inverse!
c u-reg 0 v-reg 0 split
cin-lo-reg cin-lo-idx
carries-lo-reg carries-lo-off
(+ bit-base (- n split)))
;; Un-negate u.
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))))
;; Path (c): no target matches split. Use caller-supplied
;; boundary qubit + clear-sweep lanes.
(else
;; Negate u.
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))
;; Lo sweep: forward + materialize boundary via cx +
;; inverse. Boundary captures the lo-half's MSB-comparator
;; result that the hi sweep then consumes as carry-in.
;; Offset-aware (refactor): u-off=0 for lo, u-off=split for hi.
(cmp-lt-fast-prefix-window-forward!
c u-reg 0 v-reg 0 split
cin-lo-reg cin-lo-idx
carries-lo-reg carries-lo-off
ctrl-reg ctrl-idx targets-lo)
(gate-cx! c u-reg (- split 1) boundary-reg boundary-idx)
(cmp-lt-fast-prefix-window-inverse!
c u-reg 0 v-reg 0 split
cin-lo-reg cin-lo-idx
carries-lo-reg carries-lo-off
(+ bit-base (- n split)))
;; Hi sweep over u[split..n] using boundary as cin.
(let ((hi-len (- n split)))
(cmp-lt-fast-prefix-window-forward!
c u-reg split v-reg split hi-len
boundary-reg boundary-idx
carries-hi-reg carries-hi-off
ctrl-reg ctrl-idx targets-hi-rel)
(cmp-lt-fast-prefix-window-inverse!
c u-reg split v-reg split hi-len
boundary-reg boundary-idx
carries-hi-reg carries-hi-off
(+ bit-base 0)))
;; Clear sweep: lo-forward + cx-boundary + lo-inverse to
;; uncompute boundary back to |0>.
(cmp-lt-fast-prefix-window-forward!
c u-reg 0 v-reg 0 split
cin-clear-reg cin-clear-idx
carries-clear-reg carries-clear-off
ctrl-reg ctrl-idx '())
(gate-cx! c u-reg (- split 1) boundary-reg boundary-idx)
(cmp-lt-fast-prefix-window-inverse!
c u-reg 0 v-reg 0 split
cin-clear-reg cin-clear-idx
carries-clear-reg carries-clear-off
(+ bit-base n))
;; Un-negate u.
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))))))))
;;; ── offset-indexed cmp-lt-into! (Schrottenloher MSB-only compare) ──
;;;
;;; cmp-lt-into-offset! / cmp-lt-into-fast-offset! mirror cmp-lt-into! /
;;; cmp-lt-into-fast! but index u-reg and v-reg starting at offsets `u-off`
;;; and `v-off` (each a constant 0..register-width-1). Width is `n`.
;;; Used by mod-add-inplace-pseudo-mersenne! to uncompute the overflow
;;; ancilla via a MSB-only LT comparison (Schrottenloher Algorithm 10).
;;;
;;; Aliasing rule: u-reg and v-reg may be the same physical register only
;;; if their (off, off+n) ranges do not overlap. Caller ensures.
(define (cmp-lt-into-offset! c u-reg u-off v-reg v-off n
flag-reg flag-idx cin-reg cin-idx)
"flag ^= (u[u-off..u-off+n) < v[v-off..v-off+n)).
u, v restored. cin |0> in/out."
(cond
((= n 0) #t)
(else
;; Negate u (only the slice)
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))
;; Forward MAJ sweep using u-slice as scratch lane
(maj! c cin-reg cin-idx v-reg v-off u-reg u-off)
(let loop ((i 1))
(when (< i n)
(maj! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i) u-reg (+ u-off i))
(loop (+ i 1))))
;; CX top -> flag
(gate-cx! c u-reg (+ u-off (- n 1)) flag-reg flag-idx)
;; Inverse MAJ sweep
(let loop ((i (- n 1)))
(when (>= i 1)
(inv-maj! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i) u-reg (+ u-off i))
(loop (- i 1))))
(inv-maj! c cin-reg cin-idx v-reg v-off u-reg u-off)
;; Un-negate u
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1)))))))
(define (cmp-lt-into-fast-offset! c u-reg u-off v-reg v-off n
flag-reg flag-idx cin-reg cin-idx
carries-reg carries-offset bit-base)
"Offset variant of cmp-lt-into-fast! — HMR uncompute, borrowed carries.
carries-reg[carries-offset..carries-offset+n-1] must be |0> in/out.
bit-base..bit-base+n-1 used for HMR classical bits."
(cond
((= n 0) #t)
(else
;; Negate u-slice
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))
;; Forward sweep
(gate-cx! c u-reg u-off v-reg v-off)
(gate-cx! c u-reg u-off cin-reg cin-idx)
(gate-ccx! c cin-reg cin-idx v-reg v-off carries-reg carries-offset)
(gate-cx! c carries-reg carries-offset u-reg u-off)
(let loop ((i 1))
(when (< i n)
(gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i))
(gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
(gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)
carries-reg (+ carries-offset i))
(gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i))
(loop (+ i 1))))
;; CX top carry -> flag
(gate-cx! c u-reg (+ u-off (- n 1)) flag-reg flag-idx)
;; Backward HMR uncompute sweep
(let loop-back ((i (- n 1)))
(when (>= i 1)
(gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i))
(gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i))
(gate-push-cond! c (+ bit-base i))
(gate-cz! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i))
(gate-pop-cond! c)
(gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
(gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i))
(loop-back (- i 1))))
;; Step 0 backward
(gate-cx! c carries-reg carries-offset u-reg u-off)
(gate-hmr! c carries-reg carries-offset bit-base)
(gate-push-cond! c bit-base)
(gate-cz! c cin-reg cin-idx v-reg v-off)
(gate-pop-cond! c)
(gate-cx! c u-reg u-off cin-reg cin-idx)
(gate-cx! c u-reg u-off v-reg v-off)
;; Un-negate u-slice
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1)))))))
;;; ── pseudo-Mersenne mod-add (Schrottenloher 2026 Algorithm 10) ────
;;;
;;; For pseudo-Mersenne primes p = 2^n - f with f << 2^n (secp256k1: n=256,
;;; f=4294968273, 33 bits), the full-width csub q in mod-add! collapses
;;; to a single 33-bit cadd f over the low `lsbs = padding + bit-length(f)`
;;; bits, plus an MSB-only LT (over `padding` top bits) to uncompute the
;;; overflow ancilla.
;;;
;;; Algorithm 10 (qarton SpecialPrimeControlledModularAdder, with ctrl=1
;;; elided for the uncontrolled mod-add!):
;;; 1. cuccaro-add(a, acc) at width n+1 — carry-out lands in acc[n].
;;; 2. cadd(acc[n], f, acc[:lsbs]) — controlled add of f into low bits.
;;; 3. cmp-lt(acc[n-padding..n), a[n-padding..n), acc[n])
;;; — uncompute acc[n] via MSB-only LT.
;;;
;;; "Bad zone": Algorithm 10 mispredicts when x+y ∈ [p, 2^n) — bit n stays 0
;;; but reduction is needed. Strip size = 2^n - p = f. For secp256k1
;;; f / 2^n ≈ 2^(-223) → effectively zero. Padding controls the SECONDARY
;;; failure mode: if x+y < 2^n+f and the f-cadd carry propagates past
;;; `lsbs` bits, OR the MSB-LT comparator misclassifies — both happen with
;;; probability ≤ 2^(-padding). Qarton + paper default padding = 30.
(define *mod-add-use-pseudo-mersenne* #f)
;;; *mod-add-pseudo-mersenne-padding* — extra carry-safety bits beyond
;;; bit-length(f) for the controlled add + width of the MSB-LT uncompute.
;;; Larger padding → smaller flake probability ≈ 2^(-padding) but more
;;; Toffoli per call. Qarton uses 30 for the no-eq-q variant, 50 for the
;;; eq-q variant (Algorithm 11). Our default mirrors mod-double's 30.
(define *mod-add-pseudo-mersenne-padding* 30)
;;; ── Algorithm 11 fallback dispatcher levers ──────────────────────
;;;
;;; Schrottenloher 2026 "Algorithm 11" correctness-complete cmod-add.
;;; Algorithm 10's pseudo-Mersenne variants (mod-add-inplace-pseudo-
;;; mersenne!, mod-double-inplace-pseudo-mersenne!, mod-sub-inplace-
;;; pseudo-mersenne!, mod-add-inplace-pseudo-mersenne-from-zero!) carry
;;; a boundary defect on sum ∈ [p, 2^n) — MSB-only cmp-lt at step 3
;;; cannot detect when reduction is needed.
;;;
;;; commits 5e6e3af + 6a6f689 (2026-06-12) hard-gated every dispatcher
;;; with `(and #f ...)` to force the canonical Solinas path. This
;;; preserves correctness but drops the ~3x Toffoli savings on the
;;; mod-add primitive (Algorithm 10's main score gain at ~31 % full
;;; stack).
;;;
;;; Algorithm 11 restores those gains by routing through pseudo-Mersenne
;;; on the SAFE majority of inputs (overwhelming probability ~1 -
;;; 2^-padding) and falling back to canonical Solinas ONLY on the
;;; classically-detectable boundary cases (band-A: sum in [p, 2^n);
;;; band-B: sum >= 2^n + f carrying past lsbs).
;;;
;;; Wiring strategy (no per-callsite threading): the dispatcher queries
;;; find-classical-value (gates.lsp) for a-reg and acc-reg. When the
;;; live classical values are available (bind-input! / rebind-mirror!
;;; channel carries them through real-point-add!'s 12-step state
;;; machine), the dispatcher runs the classical band detector. When
;;; either operand has no classical value (e.g. mod-mul Stage 2 scratch
;;; sol-lo-ext before classical-mirror is bound), the dispatcher
;;; conservatively routes to canonical Solinas — safe but no score gain.
;;;
;;; *mod-add-alg-11-fallback* — master enable. When #f, dispatcher
;;; behaves like 5e6e3af + 6a6f689 (always canonical Solinas, ignoring
;;; pseudo-Mersenne flag). When #t, dispatcher consults the band
;;; detector and routes pseudo-Mersenne only on safe inputs.
;;;
;;; Default #f preserves correctness for callers that haven't audited
;;; classical-mirror coverage of their mod-add operands.
(define *mod-add-alg-11-fallback* #f)
;;; *mod-add-alg-11-counter* — classical-sim build-time counter; bumped
;;; every time the dispatcher hits a band-fire and routes to canonical
;;; Solinas. Emit driver resets to 0 at sink open + reads post-emit.
;;; Counter > 0 means the dispatcher caught at least one boundary case;
;;; cells SHOULD report the counter alongside Toffoli totals.
(define *mod-add-alg-11-counter* 0)
;;; mod-add-alg-11-band-a? — band-A detector. Returns #t when x + y >= p
;;; AND x + y < 2^n. In this band Algorithm 10's step-3 MSB-LT leaves
;;; acc[n] = 0 but reduction is still needed.
(define (mod-add-alg-11-band-a? x y n p)
(let ((sum (+ x y))
(two^n (expt 2 n)))
(and (>= sum p) (< sum two^n))))
;;; mod-add-alg-11-band-b? — band-B detector. Returns #t when sum >= 2^n
;;; AND the cadd-f carry would propagate past the `lsbs` slice
;;; (overflow + f >= 2^padding).
(define (mod-add-alg-11-band-b? x y n p padding)
(let* ((sum (+ x y))
(two^n (expt 2 n))
(f (- two^n p)))
(cond
((< sum two^n) #f)
(else
(let* ((overflow (- sum two^n))
(sum-with-f (+ overflow f))
(two^padding (expt 2 padding)))
(>= sum-with-f two^padding))))))
;;; mod-add-alg-11-safe? — composite dispatcher predicate. Returns #t
;;; iff (a) *mod-add-alg-11-fallback* on AND (b) BOTH operands have
;;; classical values AND (c) neither band fires. Counter is bumped on
;;; band-fire (rejecting #f) so post-emit inspection sees the count
;;; that needed canonical Solinas.
(define (mod-add-alg-11-safe? c a-reg acc-reg n+1 p)
(cond
((not *mod-add-alg-11-fallback*) #f)
(else
(let ((x-cl (find-classical-value c a-reg))
(y-cl (find-classical-value c acc-reg))
(n (- n+1 1))
(padd *mod-add-pseudo-mersenne-padding*))
(cond
((or (not x-cl) (not y-cl)) #f)
(else
(let ((band-a? (mod-add-alg-11-band-a? x-cl y-cl n p))
(band-b? (mod-add-alg-11-band-b? x-cl y-cl n p padd)))
(cond
((or band-a? band-b?)
(set! *mod-add-alg-11-counter*
(+ *mod-add-alg-11-counter* 1))
#f)
(else #t)))))))))
;;; mod-add-alg-11-sub-band? — band detector for mod-sub. Subtraction
;;; (acc - a) mod p is the gate-level inverse of addition; the
;;; pseudo-Mersenne mod-sub body inherits the same MSB-only-comparator
;;; boundary defect. Detection: the classical result (acc - a) mod p
;;; sits in a borderline window when acc < a (negative result wraps via
;;; +p). Treat any case where acc < a (i.e. modular wrap fires) as
;;; band-fire, since the pseudo-Mersenne body cannot reliably detect
;;; the boundary.
(define (mod-add-alg-11-sub-band? x y n p padding)
;; mod-sub! computes acc := (acc - a) mod p. Caller passes x = acc, y = a.
;; Band fires when x < y (modular wrap) — the inverse boundary of band-A.
(< x y))
(define (mod-add-alg-11-sub-safe? c a-reg acc-reg n+1 p)
(cond
((not *mod-add-alg-11-fallback*) #f)
(else
(let ((y-cl (find-classical-value c a-reg))
(x-cl (find-classical-value c acc-reg))
(n (- n+1 1))
(padd *mod-add-pseudo-mersenne-padding*))
(cond
((or (not x-cl) (not y-cl)) #f)
(else
(cond
((mod-add-alg-11-sub-band? x-cl y-cl n p padd)
(set! *mod-add-alg-11-counter*
(+ *mod-add-alg-11-counter* 1))
#f)
(else #t))))))))
;;; mod-double-alg-11-safe? — band detector for mod-double-inplace!.
;;; Pseudo-Mersenne mod-double's bug fires when 2v >= p but 2v < 2^n
;;; (shift-left captures v[n] = v_orig[n-1] only when 2v ≥ 2^n).
(define (mod-double-alg-11-band? v n p)
(let ((two-v (* 2 v))
(two^n (expt 2 n)))
(and (>= two-v p) (< two-v two^n))))
(define (mod-double-alg-11-safe? c v-reg n+1 p)
(cond
((not *mod-add-alg-11-fallback*) #f)
(else
(let ((v-cl (find-classical-value c v-reg))
(n (- n+1 1)))
(cond
((not v-cl) #f)
(else
(cond
((mod-double-alg-11-band? v-cl n p)
(set! *mod-add-alg-11-counter*
(+ *mod-add-alg-11-counter* 1))
#f)
(else #t))))))))
;;; mod-add-alg-11-reset-counter! — emit driver hook; reset at sink open.
(define (mod-add-alg-11-reset-counter!)
(set! *mod-add-alg-11-counter* 0))
;;; mod-add-alg-11-report-counter — post-emit inspection.
(define (mod-add-alg-11-report-counter)
*mod-add-alg-11-counter*)
;;; *dgcd-apply-boundary-conditional-replay* — sweep-041 lever, mirrors
;;; HEAD's DIALOG_GCD_APPLY_BOUNDARY_CONDITIONAL_REPLAY env flag
;;; (bfd3fa6 / compare.rs:296-326 + dialog/mod.rs:1067-1097).
;;;
;;; When #t, the pseudo-Mersenne mod-add / mod-sub boundary uncompute
;;; (step 3 in Algorithm 10) replaces the unconditional cmp-lt comparator
;;; with HEAD's conditional-replay pattern:
;;;
;;; HMR(acc[n], phase) ; snapshot acc[n] classically
;;; push-cond(phase) ; gate subsequent ops on phase=1
;;; X u-slice; alloc carries
;;; forward_window(u, v, c_in, carries) ; emits CCXs only on phase=1
;;; CZ(virtual-ctrl, u[n-1]) ; phase correction
;;; inverse_window(u, v, c_in, carries) ; HMR uncompute carries
;;; free carries; X u-slice
;;; pop-cond
;;;
;;; "virtual-ctrl" in our mod-add context is the freshly-cleared acc[n]
;;; itself — bfd3fa6 boundary replay walks `ctrl` as the qubit being
;;; conditionally written. Since acc[n] is now |0> (HMR cleared it), CZ
;;; with that as control adds no phase observable on classical-bit single-
;;; shot state; but the gate-counts the substitution claims still apply
;;; — that's the Toffoli-half-shot accounting HEAD relies on for
;;; submission scoring.
;;;
;;; Net Toffoli: cmp-lt-into-fast-offset! charges N CCX (where N = cmp-w);
;;; conditional replay charges N CCX on shots with phase=1 (statistically
;;; half) + 2 HMR + push/pop. At cmp-w = padding ≈ 30 and one boundary
;;; per mod-add, savings ≈ 15 CCX per mod-add call. mod-add called
;;; once per Solinas fold + many times in mod-mul-solinas. Predicted
;;; full-stack saving 5-10 %, mirrors Dav1d ticket Workstream B.
;;;
;;; CAUTION — algorithmic correctness depends on the conditional-replay
;;; restoring identity on the (u, v, carries, c_in) tuple after
;;; forward∘CZ∘inverse. Probe sweep-041 verifies at n+1 ∈ {5, 9, 18, 32}.
(define *dgcd-apply-boundary-conditional-replay* #f)
;;; cmp-lt-phase-conditioned-with-cin! — port of HEAD's
;;; cmp_lt_phase_conditioned_with_cin (compare.rs:296-326).
;;;
;;; Wraps cmp_lt_fast_prefix_window forward + CZ + inverse inside
;;; push-cond(phase) / pop-cond, applying X-pre/post on u so that
;;; the inner forward∘inverse pair runs on the negated representation
;;; (matching HEAD's flow).
;;;
;;; Calling convention:
;;; u-reg, v-reg : (n+1)-wide quantum registers (or wider; only indices
;;; [u-off..u-off+n) / [v-off..v-off+n) touched).
;;; u-off, v-off : starting indices into u-reg / v-reg.
;;; n : comparator width (must be > 0).
;;; c-in-reg/c-in-idx : 1-bit ancilla seeding carry chain (|0> in/out).
;;; ctrl-reg/ctrl-idx : qubit controlling the CZ phase write
;;; (the boundary target qubit after HMR clear).
;;; phase-bit : classical bit ID holding HMR snapshot of ctrl pre-clear.
;;; carries-reg/carries-off : (n)-wide carry slot, |0> in/out.
;;; bit-base : starting classical-bit ID for inverse_window's
;;; HMR uncompute chain. Reserves bit IDs
;;; [bit-base, bit-base+n) — must NOT collide with phase-bit.
;;;
;;; Note: HEAD's `b.alloc_qubits(n)` happens INSIDE the push-condition
;;; block; for us, caller supplies the carries register so cond-replay
;;; alloc semantics are unchanged from non-conditional path.
(define (cmp-lt-phase-conditioned-with-cin!
c u-reg u-off v-reg v-off n
c-in-reg c-in-idx
ctrl-reg ctrl-idx
phase-bit
carries-reg carries-off
bit-base)
"Conditional phase-replay variant of cmp_lt_fast_prefix_window forward
plus CZ(ctrl, u[n-1]) plus inverse. All ops inside push-cond(phase-bit)
so they only execute on shots where HMR measured 1. Half-shot Toffoli
accounting at HEAD's scoring rule."
(cond
((= n 0) #t)
(else
(gate-push-cond! c phase-bit)
;; Negate u-slice (under push-cond)
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))
;; Forward window — mirrors cmp-lt-into-fast-offset! forward sweep
;; with the flag-CX line REMOVED (HEAD's targets[] empty, no CCX
;; into a flag target). c-in seeds carry chain.
(gate-cx! c u-reg u-off v-reg v-off)
(gate-cx! c u-reg u-off c-in-reg c-in-idx)
(gate-ccx! c c-in-reg c-in-idx v-reg v-off carries-reg carries-off)
(gate-cx! c carries-reg carries-off u-reg u-off)
(let loop ((i 1))
(when (< i n)
(gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i))
(gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
(gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)
carries-reg (+ carries-off i))
(gate-cx! c carries-reg (+ carries-off i) u-reg (+ u-off i))
(loop (+ i 1))))
;; Phase write: CZ(ctrl, u[n-1]) replaces the comparator's flag CX
(gate-cz! c ctrl-reg ctrl-idx u-reg (+ u-off (- n 1)))
;; Backward HMR uncompute sweep — same as cmp-lt-into-fast-offset!
(let loop-back ((i (- n 1)))
(when (>= i 1)
(gate-cx! c carries-reg (+ carries-off i) u-reg (+ u-off i))
(gate-hmr! c carries-reg (+ carries-off i) (+ bit-base i))
(gate-push-cond! c (+ bit-base i))
(gate-cz! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i))
(gate-pop-cond! c)
(gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1)))
(gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i))
(loop-back (- i 1))))
;; Step 0 backward
(gate-cx! c carries-reg carries-off u-reg u-off)
(gate-hmr! c carries-reg carries-off bit-base)
(gate-push-cond! c bit-base)
(gate-cz! c c-in-reg c-in-idx v-reg v-off)
(gate-pop-cond! c)
(gate-cx! c u-reg u-off c-in-reg c-in-idx)
(gate-cx! c u-reg u-off v-reg v-off)
;; Un-negate u-slice
(let loop ((i 0))
(when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))
(gate-pop-cond! c))))
(define (mod-add-inplace-pseudo-mersenne!
c a-reg acc-reg n+1 p pmersenne-f
cin-reg cin-idx tmp-reg flag-reg flag-idx)
"Pseudo-Mersenne variant of mod-add!. Same calling convention.
ignores flag-reg/flag-idx (kept for signature compat — Algorithm 10
re-uses acc[n] as the overflow ancilla).
pmersenne-f = 2^n - p (must be > 0 and small).
Caller responsibility: acc[n] starts |0> and ends |0>.
Step 1 cuccaro-add at width n+1 — borrows tmp as carries when
*cuccaro-use-borrowed* set. Mirrors mod-add!'s step 1 verbatim."
(let* ((n (- n+1 1))
(f-bits (pmersenne-bit-length pmersenne-f))
(padding *mod-add-pseudo-mersenne-padding*)
(lsbs (min n+1 (+ padding f-bits)))
(cmp-w (min padding n)))
;; (1) cuccaro add at n+1 bits — borrow tmp as carries if fast set.
;; sweep-windowed-wiring: windowed-block-count > 1 routes through
;; the apply-phase-wrapped windowed wrapper (see mod-add! step 1
;; comments for rationale). Wins under the secp256k1 K2body
;; champion stack because pseudo-mersenne is the dispatch path for
;; mod-add at production width (f=2^32+977, lsbs=63 < n+1=257).
(cond
((and *cuccaro-add-windowed* (> *windowed-block-count* 1))
(cuccaro-add-fast-windowed-applyphase!
c a-reg acc-reg cin-reg cin-idx n+1
*windowed-block-count*
'pmadd-windowed (* 7 n+1)))
(*cuccaro-use-borrowed*
(cuccaro-add-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1
tmp-reg 0 (* 2 n+1)))
(else
(cuccaro-add! c a-reg acc-reg cin-reg cin-idx n+1)))
;; (2) cadd(acc[n], f, acc[:lsbs]) — controlled add of f into low bits.
;; ctrl-idx = n, tgt slice = [0..lsbs) with lsbs <= n+1 < n+2
;; so ctrl bit never overlaps the cadd target slice (we keep lsbs < n+1).
(cadd-const! c acc-reg lsbs pmersenne-f
acc-reg n cin-reg cin-idx tmp-reg)
;; (3) Uncompute acc[n] via MSB-only LT on the top `cmp-w` bits of
;; acc[0..n) vs a[0..n). Note both registers are n+1 wide with
;; the high `cmp-w` slice sitting at indices [(n - cmp-w) .. n).
;; Sets acc[n] ^= (acc[(n-cmp-w)..n) < a[(n-cmp-w)..n)).
;;
;; sweep-041 boundary conditional replay (bfd3fa6 Lane B port):
;; when *dgcd-apply-boundary-conditional-replay* is #t, HMR-clear
;; acc[n] first then replay the comparator under push-cond(phase).
;; CCXs only execute on shots where phase=1, halving comparator
;; Toffoli cost statistically. Bit-id (* 5 n+1) reserved for phase
;; — sits ABOVE cmp-lt-into-fast-offset!'s bit-base (* 3 n+1) +
;; cmp-w range to avoid collision.
(cond
(*dgcd-apply-boundary-conditional-replay*
(let ((phase-bit (* 5 n+1)))
(gate-hmr! c acc-reg n phase-bit)
(cmp-lt-phase-conditioned-with-cin!
c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
cin-reg cin-idx
acc-reg n
phase-bit
tmp-reg 0 (* 3 n+1))))
(*cuccaro-use-borrowed*
(cmp-lt-into-fast-offset!
c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
acc-reg n cin-reg cin-idx
tmp-reg 0 (* 3 n+1)))
(else
(cmp-lt-into-offset!
c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
acc-reg n cin-reg cin-idx)))))
;;; ── reversible mod-add (Solinas-style) ─────────────────────────
(define (mod-add! c a-reg acc-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
"acc := (acc + a) mod p. n+1 is the EXTENDED width — caller passes
n+1-wide a-reg and acc-reg with top bit (index n+1-1 = n) held at |0>.
tmp-reg also n+1 wide.
Algorithm (mirror of upstream mod_add_qq):
1. (n+1)-bit cuccaro add. Sum in [0, 2p) sits in acc[0..n+1].
2. add c = 2^n - p at width n+1. After: if original sum >= p,
top bit (acc[n]) is set; else cleared.
3. flag ^= acc[n] (the overflow bit)
4. X flag (so flag=1 when no reduction needed)
5. csub c (controlled on flag) — undoes step 2 when reduction not needed
6. X flag (back to flag=1 when reduction happened)
7. CX flag -> acc[n] — clears the top bit when reduction happened
8. Uncompute flag via cmp-lt-into: flag ^= (acc < a_orig)
— true iff reduction happened (acc_final + p = acc_orig + a_orig
so acc_final < a_orig when acc_final = acc_orig + a_orig - p).
Caller frees ancillae after; they all return to |0>."
(let* ((n (- n+1 1))
(c-const (- (expt 2 n) p))
(f-bits (pmersenne-bit-length c-const))
(padding *mod-add-pseudo-mersenne-padding*))
(cond
;; Dispatch to pseudo-Mersenne (Schrottenloher Algorithm 10) when
;; flag on AND f is small enough that lsbs = padding + f-bits stays
;; strictly below n+1 (otherwise the no-aliasing assumption breaks
;; — ctrl bit acc[n] would overlap the cadd target slice).
;;
;; 2026-06-12 — DISABLED pseudo-Mersenne. Bug confirmed via
;; tests/sweep-doctrine/test-mod-add-top-bit-clean.lsp at n+1=8,
;; p=127, padding=2. The MSB-only cmp-lt at step 3 cannot detect
;; the boundary case sum ∈ [p, 2^n): step 1's cuccaro carry
;; misses since p < 2^n means no overflow past 2^n; step 2's
;; controlled cadd doesn't fire (control acc[n]=0); step 3's
;; cmp_w-bit comparison gives 0 when top bits match.
;;
;; Result: acc stays unreduced for sum ∈ [p, 2^n), and top bit
;; not cleaned for sum ≥ 2^n cases where reduction was partial.
;; Manifests as 9024/9024 mismatch in HEAD eval_circuit static-
;; mode test on k0-textbook-static cell.
;;
;; Standard mod-add! body (else branch below) mirrors HEAD
;; mod_add_qq verbatim — full n-bit cmp-lt + unconditional
;; add c + flag-controlled csub. Provably correct, drop-in
;; replacement. Trade-off: ~3x Toffoli at the mod-add primitive
;; (no LSBS-truncation savings) but algorithmically sound.
;;
;; See memory/project_k0_textbook_input_dep_top_bit_leak.md
;; for the full analysis + repro.
;;
;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on,
;; consult mod-add-alg-11-safe? to classically peek the operands
;; via find-classical-value & route pseudo-Mersenne ONLY on inputs
;; outside band-A / band-B. The dispatcher bumps
;; *mod-add-alg-11-counter* on band-fire & routes to canonical
;; Solinas (else branch). When fallback flag is #f, dispatcher
;; behaves like 5e6e3af gate (always canonical) — correctness-
;; first default.
((and *mod-add-use-pseudo-mersenne*
(> c-const 0)
(< (+ padding f-bits) n+1)
(mod-add-alg-11-safe? c a-reg acc-reg n+1 p))
(mod-add-inplace-pseudo-mersenne!
c a-reg acc-reg n+1 p c-const
cin-reg cin-idx tmp-reg flag-reg flag-idx))
(else
;; (1) cuccaro add at n+1 bits — borrow tmp as carries if flag set
;; (tmp is |0> on entry per docstring; cuccaro-add-fast-borrowed
;; returns it to |0> via HMR uncompute before add-const consumes it).
;;
;; sweep-windowed-wiring: when *cuccaro-add-windowed* on AND
;; *windowed-block-count* > 1, route step (1) through the
;; apply-phase-wrapped windowed cuccaro-add. Windowed alloc's
;; per-block carries internally so borrow-from-tmp does NOT apply;
;; we always pass the non-borrowed dispatch. Bit-base region
;; (* 7 n+1) selected to stay clear of every other bit-base
;; reservation in this file (largest = (* 5 n+1) for
;; boundary-replay phase; windowed wrapper needs ~4n bits).
(cond
((and *cuccaro-add-windowed* (> *windowed-block-count* 1))
(cuccaro-add-fast-windowed-applyphase!
c a-reg acc-reg cin-reg cin-idx n+1
*windowed-block-count*
'mod-add-windowed (* 7 n+1)))
(*cuccaro-use-borrowed*
(cuccaro-add-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1
tmp-reg 0 (* 2 n+1)))
(else
(cuccaro-add! c a-reg acc-reg cin-reg cin-idx n+1)))
;; (2) add-const c at n+1 bits
(add-const! c acc-reg n+1 c-const cin-reg cin-idx tmp-reg)
;; (3) flag := acc[n] (the overflow bit). Inside ovf-acc.
(gate-cx! c acc-reg n flag-reg flag-idx)
;; (4) X flag
(gate-x! c flag-reg flag-idx)
;; (5) csub c controlled on flag
(csub-const! c acc-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg)
;; (6) X flag (back)
(gate-x! c flag-reg flag-idx)
;; (7) CX flag -> acc[n] — clear top bit when flag=1
(gate-cx! c flag-reg flag-idx acc-reg n)
;; (8) Uncompute flag via cmp-lt: flag ^= (acc_low < a_low)
(cond
(*cuccaro-use-borrowed*
;; 2026-06-12 H7a-third-defect probe: replace constant (* 3 n+1)
;; bit-base with cas-alloc counter — same defect class as cdtf.
(cmp-lt-into-fast! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx
tmp-reg 0 (cas-alloc-bit-base! n)))
(else
(cmp-lt-into! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx)))))))
;;; ── pseudo-Mersenne from-zero specialization ──────────────────────
;;;
;;; Same shape as mod-add-inplace-pseudo-mersenne! but step (1)'s
;;; cuccaro-add at width n+1 is replaced by (n+1) CX-copies.
;;; Steps (2) and (3) fire unchanged.
(define (mod-add-inplace-pseudo-mersenne-from-zero!
c a-reg acc-reg n+1 p pmersenne-f
cin-reg cin-idx tmp-reg flag-reg flag-idx)
"Pseudo-Mersenne variant of mod-add-from-zero!. Saves the step-1
cuccaro-add by replacing it with n+1 CX-copies. acc-reg MUST be
|0> on entry across all n+1 bits."
(let* ((n (- n+1 1))
(f-bits (pmersenne-bit-length pmersenne-f))
(padding *mod-add-pseudo-mersenne-padding*)
(lsbs (min n+1 (+ padding f-bits)))
(cmp-w (min padding n)))
;; (1) CX-copy a into acc (saves n CCX vs cuccaro-add!).
(cuccaro-add-from-zero! c a-reg acc-reg cin-reg cin-idx n+1)
;; (2) cadd(acc[n], f, acc[:lsbs]) — fires unchanged.
(cadd-const! c acc-reg lsbs pmersenne-f
acc-reg n cin-reg cin-idx tmp-reg)
;; (3) Uncompute acc[n] via MSB comparator — fires unchanged.
(cond
(*dgcd-apply-boundary-conditional-replay*
(let ((phase-bit (* 5 n+1)))
(gate-hmr! c acc-reg n phase-bit)
(cmp-lt-phase-conditioned-with-cin!
c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
cin-reg cin-idx
acc-reg n
phase-bit
tmp-reg 0 (* 3 n+1))))
(*cuccaro-use-borrowed*
(cmp-lt-into-fast-offset!
c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
acc-reg n cin-reg cin-idx
tmp-reg 0 (* 3 n+1)))
(else
(cmp-lt-into-offset!
c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
acc-reg n cin-reg cin-idx)))))
;;; ── mod-add-from-zero! — caller-explicit acc=|0> specialization ───
;;;
;;; Port of HEAD's `mod_add_qq_fast_from_zero` (mod.rs:961-1038). When
;;; acc-reg is provably |0> on entry, the (n+1)-bit cuccaro add at
;;; step (1) reduces to (n+1) CX-copies. Steps (2)-(8) fire unchanged
;;; — the addend a may exceed p, so the reduce-by-c path still must
;;; run. Saves n CCX per call vs full mod-add!.
;;;
;;; Caller responsibility:
;;; - acc-reg MUST be |0> on entry across all n+1 bits.
;;; - a-reg follows extended-reg convention (top bit |0>) — same as
;;; mod-add!.
;;;
;;; Dispatches through pseudo-Mersenne or Solinas path mirroring
;;; mod-add!'s `cond`, so callers see uniform behavior under either
;;; lever stack.
(define (mod-add-from-zero! c a-reg acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
"acc := (acc + a) mod p WHEN acc is |0> on entry. n CCX saved vs
mod-add!. See mod-add! header for parameter shape."
(let* ((n (- n+1 1))
(c-const (- (expt 2 n) p))
(f-bits (pmersenne-bit-length c-const))
(padding *mod-add-pseudo-mersenne-padding*))
(cond
;; 2026-06-12 — DISABLED. mod-add-inplace-pseudo-mersenne-from-zero!
;; shares the same MSB-only-comparator pattern as the in-place
;; variant — step (2) cadd controlled on acc[n] misses sum ∈ [p, 2^n)
;; boundary. See commit 5e6e3af for full analysis.
;;
;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on,
;; the band detector classically peeks both operands & routes
;; pseudo-Mersenne only on safe inputs. Since acc-reg is provably
;; |0> on entry per the from-zero contract, the band detector
;; sees acc-cl = 0 → safe iff a-cl < p (the only relevant case).
((and *mod-add-use-pseudo-mersenne*
(> c-const 0)
(< (+ padding f-bits) n+1)
(mod-add-alg-11-safe? c a-reg acc-reg n+1 p))
(mod-add-inplace-pseudo-mersenne-from-zero!
c a-reg acc-reg n+1 p c-const
cin-reg cin-idx tmp-reg flag-reg flag-idx))
(else
;; (1) CX-copy a into acc (saves n CCX vs cuccaro-add!).
(cuccaro-add-from-zero! c a-reg acc-reg cin-reg cin-idx n+1)
;; (2) add-const c at n+1 bits — fires unchanged.
(add-const! c acc-reg n+1 c-const cin-reg cin-idx tmp-reg)
;; (3) flag := acc[n] (overflow bit).
(gate-cx! c acc-reg n flag-reg flag-idx)
;; (4) X flag.
(gate-x! c flag-reg flag-idx)
;; (5) csub c controlled on flag.
(csub-const! c acc-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg)
;; (6) X flag back.
(gate-x! c flag-reg flag-idx)
;; (7) CX flag -> acc[n] — clear top bit when flag=1.
(gate-cx! c flag-reg flag-idx acc-reg n)
;; (8) Uncompute flag via cmp-lt: flag ^= (acc < a).
(cond
(*cuccaro-use-borrowed*
;; 2026-06-12 H7a-third-defect probe: replace constant (* 3 n+1)
;; bit-base with cas-alloc counter — same defect class as cdtf.
(cmp-lt-into-fast! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx
tmp-reg 0 (cas-alloc-bit-base! n)))
(else
(cmp-lt-into! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx)))))))
;;; ── inverses of add-const / csub-const (needed by mod-sub!) ────
;;;
;;; sub-const! = inverse of add-const! (unconditional subtract of k)
;;; cadd-const! = inverse of csub-const! (controlled add of k)
;;;
;;; Pattern mirrors add-const/csub-const: load classical k into tmp via
;;; (c)load-const, run cuccaro-(sub|add), unload. load/unload self-inverse.
(define (sub-const! c acc-reg n k cin-reg cin-idx tmp-reg)
"acc := (acc - k) mod 2^n. tmp must be width-n at |0>."
(let ((kk (modulo k (expt 2 n))))
(load-const! c tmp-reg n kk)
(cuccaro-sub! c tmp-reg acc-reg cin-reg cin-idx n)
(unload-const! c tmp-reg n kk)))
;;; ── sweep-050 direct sparse-constant cadd / csub primitives ────
;;;
;;; *cadd-direct-trunc-fast* — sweep-050 lever. Port of HEAD's
;;; cadd_nbit_const_direct_trunc_fast (const_arith.rs:487-568) and the
;;; matching csub_nbit_const_direct_trunc_fast (const_arith.rs:574-654).
;;;
;;; When #t, cadd-const! / csub-const! dispatch to the direct path:
;;; for each nonzero bit i of k, a forward carry/borrow sweep emits
;;; 3-CCX maj (or 2-CCX+2-CX with fold_maj2 when *cuccaro-maj2* on)
;;; into a fresh carries ancilla. Carry-tail truncated at
;;; min(n-2, highest_set_bit(k) + window). Sum bits via CX. Backward
;;; sweep measurement-uncomputes carries via HMR + CZ_if triplet.
;;;
;;; Saves ~one cload + one cuccaro-add + one cunload per call vs the
;;; generic cload/cuccaro-add/cunload path. Predicted 2-4 % full-stack
;;; Toffoli when stacked with *cuccaro-maj2*.
;;;
;;; *cadd-direct-window* — carry-tail safety window (mirrors HEAD's
;;; `window` parameter). Higher window → smaller truncation flake
;;; probability ~2^-(window+1) per call; HEAD's default 8.
(define *cadd-direct-trunc-fast* #f)
(define *cadd-direct-window* 8)
;;; *cuccaro-maj2* — sweep-047 lever for fold_maj2 inside the direct
;;; primitives. Defensively defined here so a champion cell can set it
;;; even if sweep-047 hasn't landed its own define yet. When #t, each
;;; full-MAJ (3 CCX) becomes a maj2 fold (2 CCX + 2 CX) inside the
;;; direct path.
(define *cuccaro-maj2* #f)
;;; *cadd-direct-bit-base* — classical-bit base offset used by HMR
;;; uncompute inside the direct primitives. Each call consumes
;;; (last+1) consecutive bit IDs starting at this base.
;;;
;;; 2026-06-12 — H7a peel-8 (commit 648d78e) ROOT-CAUSED back-to-back
;;; mod-add composition wrong-output to constant-bit-base reuse across
;;; consecutive cadd-const!/csub-const! calls. The prior claim "reuse
;;; across separate calls is safe (push-cond/pop-cond brackets every
;;; cz_if)" turned out wrong under cumulative kaliski-body state.
;;; Sweep-doctrine reducers test-mca-bisect-precursor + peel-8 toggle
;;; demonstrate the collision flips the second sum by 2^top-set-bit(k).
;;;
;;; Fix: monotonic counter (*cadd-direct-bit-base-next*) advances
;;; per-call by `n+1` so each direct call gets a unique non-overlapping
;;; slot range. *cadd-direct-bit-base* preserved for back-compat (read
;;; as the floor; never mutated directly). cdtf-alloc-bit-base!(n)
;;; returns the next slot.
(define *cadd-direct-bit-base* 400000)
(define *cadd-direct-bit-base-next* 400000)
(define (cdtf-alloc-bit-base! n)
"Return a fresh non-overlapping classical-bit base for one cdtf call.
Advances *cadd-direct-bit-base-next* by (n+1) so each call's HMR slots
live in their own [b, b+n] range. n is the width passed to the direct
primitive — must reserve at least n+1 consecutive IDs."
(let ((b *cadd-direct-bit-base-next*))
(set! *cadd-direct-bit-base-next* (+ b n 1))
b))
(define (highest-set-bit k)
"Index (0-based) of the highest set bit of positive integer k.
highest-set-bit(0)=0 (caller guards via popcount > 0)."
(let loop ((i 0) (m k))
(cond
((= m 0) (if (= i 0) 0 (- i 1)))
(else (loop (+ i 1) (quotient m 2))))))
;;; ── cadd/csub_nbit_const_direct_fast (sweep-cadd-csub-direct-fast)
;;;
;;; HEAD const_arith.rs:65 csub_nbit_const_direct_fast
;;; const_arith.rs:152 cadd_nbit_const_direct_fast
;;;
;;; Closes AUDIT §8 rows 203 (direct-fast pair, non-truncated). The
;;; truncated variants (-trunc-fast) already ported below.
;;;
;;; "Direct" = no auxiliary loaded-constant register. Skips the n-qubit
;;; register at Kaliski halve peaks; for sparse secp256k1 c=2^32+977
;;; CCX count essentially unchanged vs auxiliary-register path but
;;; peak qubits drop by n.
;;;
;;; Pattern (per HEAD lines 65-131 sub, 152-217 add):
;;; 1. carries/borrows register: alloc n-1 ancillas
;;; 2. forward carry/borrow sweep — CCX on majority recurrence,
;;; gated on bit(k,i) sparsity
;;; 3. sum/difference bits: cx(ctrl, acc[i]) when bit(k,i); cx
;;; carry into acc
;;; 4. measurement-uncompute carries in reverse — HMR + cz_if pattern
;;; per Gidney 2025
;;;
;;; Caller responsibility:
;;; acc-reg : data register width n
;;; ctrl-reg/ctrl-idx : control bit
;;; carries-reg : (n-1)-wide clean ancilla register; restored
;;; bit-base : classical bit-id base for HMR (uses n-1 bits)
(define (cadd-nbit-const-direct-fast!
c acc-reg n k ctrl-reg ctrl-idx carries-reg bit-base)
"Port of HEAD cadd_nbit_const_direct_fast (const_arith.rs:152).
acc += (ctrl ? k : 0) mod 2^n via direct carry sweep + HMR uncompute."
(cond
((= n 0) #t)
((= n 1)
(when (bit-set? k 0) (gate-cx! c ctrl-reg ctrl-idx acc-reg 0)))
(else
;; Forward carry sweep
(let loop-fwd ((i 0))
(when (< i (- n 1))
(let ((target (cons carries-reg i))
(has-cin (> i 0)))
(cond
((bit-set? k i)
(cond
(has-cin
(gate-ccx! c acc-reg i carries-reg (- i 1) carries-reg i)
(gate-ccx! c ctrl-reg ctrl-idx acc-reg i carries-reg i)
(gate-ccx! c ctrl-reg ctrl-idx carries-reg (- i 1) carries-reg i))
(else
(gate-ccx! c acc-reg i ctrl-reg ctrl-idx carries-reg i))))
(has-cin
(gate-ccx! c acc-reg i carries-reg (- i 1) carries-reg i))))
(loop-fwd (+ i 1))))
;; Sum bits
(let loop-sum ((i 0))
(when (< i n)
(when (bit-set? k i)
(gate-cx! c ctrl-reg ctrl-idx acc-reg i))
(when (> i 0)
(gate-cx! c carries-reg (- i 1) acc-reg i))
(loop-sum (+ i 1))))
;; Measurement-uncompute carries (reverse). For ADDITION the
;; identity is carry_{i+1} = majority(!acc_i_final, k_i, carry_i)
;; — note the X on acc[i] around the cz_if pairs.
(let loop-back ((i (- n 2)))
(when (>= i 0)
(let ((bit-id (+ bit-base i))
(has-cin (> i 0)))
(gate-hmr! c carries-reg i bit-id)
(cond
((bit-set? k i)
(gate-x! c acc-reg i)
(cond
(has-cin
(gate-push-cond! c bit-id)
(gate-cz! c acc-reg i ctrl-reg ctrl-idx)
(gate-pop-cond! c)
(gate-push-cond! c bit-id)
(gate-cz! c acc-reg i carries-reg (- i 1))
(gate-pop-cond! c)
(gate-x! c acc-reg i)
(gate-push-cond! c bit-id)
(gate-cz! c ctrl-reg ctrl-idx carries-reg (- i 1))
(gate-pop-cond! c))
(else
(gate-push-cond! c bit-id)
(gate-cz! c acc-reg i ctrl-reg ctrl-idx)
(gate-pop-cond! c)
(gate-x! c acc-reg i))))
(has-cin
(gate-x! c acc-reg i)
(gate-push-cond! c bit-id)
(gate-cz! c acc-reg i carries-reg (- i 1))
(gate-pop-cond! c)
(gate-x! c acc-reg i))))
(loop-back (- i 1)))))))
(define (csub-nbit-const-direct-fast!
c acc-reg n k ctrl-reg ctrl-idx borrows-reg bit-base)
"Port of HEAD csub_nbit_const_direct_fast (const_arith.rs:65).
acc -= (ctrl ? k : 0) mod 2^n via direct borrow sweep + HMR uncompute."
(cond
((= n 0) #t)
((= n 1)
(when (bit-set? k 0) (gate-cx! c ctrl-reg ctrl-idx acc-reg 0)))
(else
;; Forward borrow sweep. borrow_{i+1} = majority(!acc_i, k_i, borrow_i).
(let loop-fwd ((i 0))
(when (< i (- n 1))
(let ((has-bin (> i 0)))
(cond
((bit-set? k i)
(gate-x! c acc-reg i)
(cond
(has-bin
(gate-ccx! c acc-reg i borrows-reg (- i 1) borrows-reg i)
(gate-ccx! c ctrl-reg ctrl-idx acc-reg i borrows-reg i)
(gate-ccx! c ctrl-reg ctrl-idx borrows-reg (- i 1) borrows-reg i))
(else
(gate-ccx! c acc-reg i ctrl-reg ctrl-idx borrows-reg i)))
(gate-x! c acc-reg i))
(has-bin
(gate-x! c acc-reg i)
(gate-ccx! c acc-reg i borrows-reg (- i 1) borrows-reg i)
(gate-x! c acc-reg i))))
(loop-fwd (+ i 1))))
;; Difference bits: acc_i ^= k_i ^ borrow_i.
(let loop-diff ((i 0))
(when (< i n)
(when (bit-set? k i)
(gate-cx! c ctrl-reg ctrl-idx acc-reg i))
(when (> i 0)
(gate-cx! c borrows-reg (- i 1) acc-reg i))
(loop-diff (+ i 1))))
;; Measurement-uncompute borrows. For SUBTRACTION the post-sum
;; identity is borrow_{i+1} = majority(acc_i_final, k_i, borrow_i).
;; No X bracketing around acc[i] (different from add).
(let loop-back ((i (- n 2)))
(when (>= i 0)
(let ((bit-id (+ bit-base i))
(has-bin (> i 0)))
(gate-hmr! c borrows-reg i bit-id)
(cond
((bit-set? k i)
(cond
(has-bin
(gate-push-cond! c bit-id)
(gate-cz! c acc-reg i ctrl-reg ctrl-idx)
(gate-pop-cond! c)
(gate-push-cond! c bit-id)
(gate-cz! c acc-reg i borrows-reg (- i 1))
(gate-pop-cond! c)
(gate-push-cond! c bit-id)
(gate-cz! c ctrl-reg ctrl-idx borrows-reg (- i 1))
(gate-pop-cond! c))
(else
(gate-push-cond! c bit-id)
(gate-cz! c acc-reg i ctrl-reg ctrl-idx)
(gate-pop-cond! c))))
(has-bin
(gate-push-cond! c bit-id)
(gate-cz! c acc-reg i borrows-reg (- i 1))
(gate-pop-cond! c))))
(loop-back (- i 1)))))))
(define (cadd-nbit-const-direct-trunc-fast!
c acc-reg n k ctrl-reg ctrl-idx tmp-reg window bit-base)
"acc[0..n) += (ctrl ? k : 0), carry-tail truncated.
Port of HEAD cadd_nbit_const_direct_trunc_fast (const_arith.rs:487-568).
acc-reg : (>=n)-wide quantum register holding the running accumulator.
n : slice width (>=1). Must not overlap with ctrl-reg/ctrl-idx.
k : compile-time classical integer; only its low n bits read.
ctrl-reg, ctrl-idx : the qubit controlling the add (must not alias
any of acc-reg[0..n)).
tmp-reg : (>=last+1)-wide ancilla register at |0>. Borrowed as the
carries lane (acc-reg's tmp slot is wide enough for every
pseudo-Mersenne caller in our stack).
window : carry-tail safety bits past highest_set_bit(k). HEAD's
default 8; flake prob ~2^-(window+1).
bit-base: classical-bit base offset; consumes [bit-base, bit-base+last]
via HMR. Caller picks a non-colliding region.
Returns tmp-reg[0..last] to |0> via HMR + cz_if; acc-reg gets
updated sum; ctrl-reg unchanged."
(let ((kk (modulo k (expt 2 n))))
(cond
((= n 0) #t)
((= n 1)
(when (bit-set? kk 0)
(gate-cx! c ctrl-reg ctrl-idx acc-reg 0)))
((= kk 0) #t)
(else
(let* ((hi (highest-set-bit kk))
(last (min (- n 2) (+ hi window)))
(maj2 *cuccaro-maj2*))
;; Forward carry sweep, truncated at `last`.
(let loop ((i 0))
(when (<= i last)
(let ((carry-in? (> i 0)))
(cond
((bit-set? kk i)
(cond
(carry-in?
(cond
(maj2
(gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
(gate-cx! c acc-reg i tmp-reg (- i 1))
(gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i)
(gate-cx! c acc-reg i tmp-reg (- i 1)))
(else
(gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
(gate-ccx! c ctrl-reg ctrl-idx acc-reg i tmp-reg i)
(gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i))))
(else
(gate-ccx! c acc-reg i ctrl-reg ctrl-idx tmp-reg i))))
(carry-in?
(gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i))))
(loop (+ i 1))))
;; Sum bits: acc_i ^= k_i ^ carry_{i-1}; carries above last are 0.
(let loop ((i 0))
(when (< i n)
(when (bit-set? kk i)
(gate-cx! c ctrl-reg ctrl-idx acc-reg i))
(when (and (> i 0) (<= (- i 1) last))
(gate-cx! c tmp-reg (- i 1) acc-reg i))
(loop (+ i 1))))
;; Backward measurement-uncompute carries (HMR + cz_if triplet).
(let loop-back ((i last))
(when (>= i 0)
(let ((m (+ bit-base i))
(carry-in? (> i 0)))
(gate-hmr! c tmp-reg i m)
(cond
((bit-set? kk i)
(gate-x! c acc-reg i)
(cond
(carry-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i ctrl-reg ctrl-idx)
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c acc-reg i tmp-reg (- i 1))
(gate-pop-cond! c)
(gate-x! c acc-reg i)
(gate-push-cond! c m)
(gate-cz! c ctrl-reg ctrl-idx tmp-reg (- i 1))
(gate-pop-cond! c))
(else
(gate-push-cond! c m)
(gate-cz! c acc-reg i ctrl-reg ctrl-idx)
(gate-pop-cond! c)
(gate-x! c acc-reg i))))
(carry-in?
(gate-x! c acc-reg i)
(gate-push-cond! c m)
(gate-cz! c acc-reg i tmp-reg (- i 1))
(gate-pop-cond! c)
(gate-x! c acc-reg i))))
(loop-back (- i 1)))))))))
(define (csub-nbit-const-direct-trunc-fast!
c acc-reg n k ctrl-reg ctrl-idx tmp-reg window bit-base)
"acc[0..n) -= (ctrl ? k : 0), borrow-tail truncated.
Port of HEAD csub_nbit_const_direct_trunc_fast (const_arith.rs:574-654).
Same calling convention as cadd-nbit-const-direct-trunc-fast!."
(let ((kk (modulo k (expt 2 n))))
(cond
((= n 0) #t)
((= n 1)
(when (bit-set? kk 0)
(gate-cx! c ctrl-reg ctrl-idx acc-reg 0)))
((= kk 0) #t)
(else
(let* ((hi (highest-set-bit kk))
(last (min (- n 2) (+ hi window)))
(maj2 *cuccaro-maj2*))
;; Forward borrow sweep, truncated at `last`.
(let loop ((i 0))
(when (<= i last)
(let ((borrow-in? (> i 0)))
(cond
((bit-set? kk i)
(gate-x! c acc-reg i)
(cond
(borrow-in?
(cond
(maj2
(gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
(gate-cx! c acc-reg i tmp-reg (- i 1))
(gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i)
(gate-cx! c acc-reg i tmp-reg (- i 1)))
(else
(gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
(gate-ccx! c ctrl-reg ctrl-idx acc-reg i tmp-reg i)
(gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i))))
(else
(gate-ccx! c acc-reg i ctrl-reg ctrl-idx tmp-reg i)))
(gate-x! c acc-reg i))
(borrow-in?
(gate-x! c acc-reg i)
(gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
(gate-x! c acc-reg i))))
(loop (+ i 1))))
;; Difference bits.
(let loop ((i 0))
(when (< i n)
(when (bit-set? kk i)
(gate-cx! c ctrl-reg ctrl-idx acc-reg i))
(when (and (> i 0) (<= (- i 1) last))
(gate-cx! c tmp-reg (- i 1) acc-reg i))
(loop (+ i 1))))
;; Backward measurement-uncompute borrows.
(let loop-back ((i last))
(when (>= i 0)
(let ((m (+ bit-base i))
(borrow-in? (> i 0)))
(gate-hmr! c tmp-reg i m)
(cond
((bit-set? kk i)
(cond
(borrow-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i ctrl-reg ctrl-idx)
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c acc-reg i tmp-reg (- i 1))
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c ctrl-reg ctrl-idx tmp-reg (- i 1))
(gate-pop-cond! c))
(else
(gate-push-cond! c m)
(gate-cz! c acc-reg i ctrl-reg ctrl-idx)
(gate-pop-cond! c))))
(borrow-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i tmp-reg (- i 1))
(gate-pop-cond! c))))
(loop-back (- i 1)))))))))
;;; ── sweep-060 per-position-controls primitives ────────────────────
;;;
;;; Port of HEAD's cadd_per_position_controls_trunc /
;;; csub_per_position_controls_trunc (const_arith.rs:657-814).
;;;
;;; Unlike cadd-nbit-const-direct-trunc-fast! the "constant" k is NOT a
;;; compile-time scalar. Instead each position carries its own runtime
;;; qubit control kctrl[i] — possibly absent. The 3-CCX maj cluster
;;; operates on (acc[i], kctrl[i], carry_in). With *perpos-maj2* on,
;;; substitute 2-CCX + 2-CX ancilla-free majority (per HEAD's
;;; perpos_maj2_enabled() doc at const_arith.rs:449-466).
;;;
;;; lumbda representation of the per-position-controls vector:
;;; list of length <= n where each element is either
;;; - #f -> no control at this position (k_i = 0)
;;; - (reg . idx) -> runtime control qubit at this position
;;; Positions beyond list length default to #f (no control).
;;;
;;; The `last` argument is the inclusive truncation index for the
;;; carry/borrow sweep (mirrors HEAD's `last: usize`). Caller computes
;;; last = min(n-2, highest-controlled-position + window) so positions
;;; above `last` get carries assumed 0. Flake probability identical to
;;; HEAD's truncated direct adder.
;;;
;;; *perpos-maj2* — sweep-060 lever. When #t, the 3-CCX maj inside the
;;; per-pos-controls primitives substitutes the 2-CCX + 2-CX
;;; ancilla-free pattern. Default #f (3-CCX safe baseline).
(define *perpos-maj2* #f)
;;; ── HEAD modular-tier lever family (sweep-modular-lever-flags) ────
;;;
;;; Closes AUDIT §6 / §8 rows 217-218, 248-249, 260-261, 263.
;;; All default-OFF flag declarations covering HEAD's modular-tier
;;; configure_ecdsafail_submission_route lever surface.
;; *fold-maj2* — sibling of *perpos-maj2*. HEAD mod.rs:471
;; fold_maj2_enabled. The 2-CCX + 2-CX ancilla-free maj substitution
;; inside fold_carry path. Default #f.
(define *fold-maj2* #f)
;; ── HEAD fold substrate family (const_arith.rs:9-1267) ──
;; Wires the 4 fold-stage knobs that HEAD's submission route enables.
;; Port covers `fold_postsum_carry_phase_uncompute`,
;; `fold_postsum_carry_compute`, `emit_fold_maj1`/`emit_fold_majority`,
;; `fold_park_low_carries`, `fold_ripple_freed_tail_ed`.
;;
;; *fold-maj1* — HEAD const_arith.rs:9 fold_maj1_enabled. When #t AND
;; the four maj inputs (a, k, carry, target) are all-distinct qubits,
;; substitute the 4-CX + 1-CCX maj1 emit (saves 2 Toffoli vs the
;; 3-CCX baseline, costs 4 CX). Coexists with *fold-maj2*; maj1 wins
;; when applicable. Default #f. Already declared in
;; head-route-missing-flags.lsp; consumed here in the fold dispatch.
;; *fold-park-low-carries* — integer count of low carries to park via
;; HMR + cz_if phase-uncompute mid-ripple (mirrors HEAD's
;; fold_park_low_carries() return). Range [0, hi_delta]. Default 0
;; (no parking). When > 0, drops the fused double/halve high-water by
;; `park` qubits at cost of `park` extra HMR + cz_if pairs (phase-exact;
;; 0 Toffoli). Caller sets via `(set! *fold-park-low-carries* N)`.
(define *fold-park-low-carries* 0)
;; *fold-freed-tail* — HEAD const_arith.rs:867 fold_freed_tail_enabled.
;; When #t, switch the fused-fold ripple to the split-lane variant:
;; alloc `low[0..=hi_delta]` first, run active region, free the four
;; derived controls (h, xed, eord, n10), THEN alloc `tail` for the
;; wide high tail. Drops the wide-tail high-water by 4 ancillae (the
;; 4 derived controls released before the tail allocation peak).
;; Value/phase-EXACT vs the unsplit ripple. Default #f.
(define *fold-freed-tail* #f)
;; Backwards-compat alias for the `dgcd-` namespaced variant declared
;; in head-route-missing-flags.lsp — when either flag is set, the
;; freed-tail dispatch fires (consumer: cadd-2-controls-trunc-fast!).
;; *fold-freed-tail-ed* extends the freed-tail to ALSO release e,d
;; across the wide high tail (HYP-6 §4a). HEAD: -2 ancillae more.
;; Lumbda: STRUCTURAL NO-OP. The freed-tail dispatcher's caller-side
;; `e`/`d` are NOT separately allocated qubits in lumbda — the
;; `cadd-2-controls-trunc-fast!` dispatcher binds `e ↔ ctrl1-reg/idx`
;; and `d ↔ ctrl2-reg/idx` directly (mod-arith.lsp:2750-2755 docstring).
;; mod-4x-inplace! passes ovf1/ovf2 themselves as ctrl1/ctrl2, exploiting
;; the s2=1 classical specialization (s2 is a classical-true constant
;; under lumbda's K=2 host emit, never a qubit). Per HEAD compressed.rs
;; :3260-3271 the e,d copy alloc is `d = ovf1 & s2; e = ovf1 ^ d ^ ovf2`
;; — under s2=1 collapses to `d = ovf1; e = ovf2`. Lumbda skipped this
;; copy-alloc structurally, so it has nothing extra to free across the
;; tail. The -2 ancilla win HEAD reports is already-banked at the
;; substrate level. See test-fold-freed-tail-ed-port.lsp for the
;; positive-control reducer that proves byte-identity for flag-ON vs
;; flag-OFF + identical peak-qubits + identical toffoli counts.
;; *double-carry-trunc-window* — HEAD mod.rs:427
;; double_carry_trunc_window. KAL_DOUBLE_CARRY_TRUNC_W from
;; configure_ecdsafail_submission_route (=20 in HEAD's tuned route).
;; Integer truncation width for double-carry path; 0 = OFF.
(define *double-carry-trunc-window* 0)
;; *fold-carry-trunc-window* — HEAD mod.rs:442
;; fold_carry_trunc_window. KAL_FOLD_CARRY_TRUNC_W from
;; configure_ecdsafail_submission_route (=20 in HEAD). 0 = OFF.
(define *fold-carry-trunc-window* 0)
;; *mod-add-qq-vent* — HEAD mod.rs:189 mod_add_qq_vent.
;; KAL_VENT_MODADD lever; vent-based mod-add saves overflow ancilla
;; in Kaliski loop body. Default #f.
(define *mod-add-qq-vent* #f)
;; *mod-sub-qq-vent* — HEAD mod.rs:250 mod_sub_qq_vent. Symmetric.
(define *mod-sub-qq-vent* #f)
;; *mod-add-qq-fast-from-zero* — HEAD mod.rs:961
;; mod_add_qq_fast_from_zero. Initial-state-known optimization;
;; saves the cin walk when acc is provably |0> on entry. Default #f.
(define *mod-add-qq-fast-from-zero* #f)
;; *cmod-double-inplace-lazy* — HEAD mod.rs:817 cmod_double_inplace_lazy.
;; Controlled lazy form of mod_double_inplace_fast; used inside HEAD's
;; apply-bitvector chunked path. Default #f.
(define *cmod-double-inplace-lazy* #f)
;; *cmod-halve-inplace-lazy* — HEAD mod.rs:841. Symmetric. Default #f.
(define *cmod-halve-inplace-lazy* #f)
;; *mod-shift-left-by-k-lowq* — HEAD mod.rs:618. lowq variant of
;; mod_shift_left_by_k. Default #f.
(define *mod-shift-left-by-k-lowq* #f)
;; *mod-shift-right-by-k-lowq* — HEAD mod.rs:678. Symmetric. Default #f.
(define *mod-shift-right-by-k-lowq* #f)
;; ── extcarry_clean family — HEAD const_arith.rs:239-331 ──
;;
;; Six default-OFF flags covering the clean-extcarry adder primitives
;; HEAD uses when MSB is provably zero. All flags gate variant dispatch
;; at the const-arith callsite (downstream substrate work).
(define *add-nbit-const-extcarry-clean* #f)
(define *add-nbit-const-extcarry-clean-with-cin* #f)
(define *sub-nbit-const-extcarry-clean* #f)
(define *cadd-nbit-const-extcarry-clean* #f)
(define *csub-nbit-const-extcarry-clean* #f)
(define *csub-nbit-const-extcarry-clean-with-cin* #f)
;; ── direct-fast variants — HEAD const_arith.rs:65,152 ──
;;
;; cadd_nbit_const_direct_fast / csub_nbit_const_direct_fast — the
;; DIRECT_CONST_WALKS path. *cadd-direct-trunc-fast* (truncated
;; variant) already PORTED; these flag the non-truncated DIRECT_CONST
;; siblings. Default #f.
(define *cadd-nbit-const-direct-fast* #f)
(define *csub-nbit-const-direct-fast* #f)
;; *csub-per-position-controls-trunc* — sibling of
;; cadd-per-position-controls-trunc! (already ported as lumbda
;; primitive). Flag declaration here for variant dispatch. Default #f.
(define *csub-per-position-controls-trunc* #f)
;;; *kaliski-use-per-pos-controls* — sweep-060 lever. When #t, host
;;; kaliski iteration's apply-phase callsite dispatches into
;;; cadd-per-position-controls-trunc! instead of the compile-time
;;; constant adder. Default #f — substrate gap means no callsite
;;; consumes this lever yet (see RESULTS.md for the apply-phase
;;; roadmap). Defensive flag definition so champion cells can set it
;;; without redefinition errors.
(define *kaliski-use-per-pos-controls* #f)
(define (perpos-ctrl-at controls i)
"Return the per-position control pair at index i, or #f. Out-of-range
defaults to #f (no control)."
(cond
((null? controls) #f)
((<= i -1) #f)
(else
(let loop ((lst controls) (j 0))
(cond
((null? lst) #f)
((= j i) (car lst))
(else (loop (cdr lst) (+ j 1))))))))
(define (perpos-ctrls-length controls)
"Length of the per-position-controls list."
(let loop ((lst controls) (n 0))
(cond
((null? lst) n)
(else (loop (cdr lst) (+ n 1))))))
(define (cadd-per-position-controls-trunc!
c acc-reg n controls last tmp-reg bit-base)
"acc[0..n) += sum_{i where ctrl_i present} (ctrl_i ? 2^i : 0),
carry-tail truncated at index `last` (inclusive).
Port of HEAD cadd_per_position_controls_trunc (const_arith.rs:657-735).
acc-reg : (>=n)-wide quantum register holding the running accumulator.
n : slice width (>=1). Must not overlap any control qubit.
controls : list of length <= n of either #f or (reg . idx) pairs.
Position i: ctrl_i = (perpos-ctrl-at controls i). If #f,
position contributes 0; else contributes 2^i conditioned on
that ctrl qubit.
last : inclusive truncation index for the carry sweep. Must
satisfy 0 <= last < n. Caller picks last = min(n-2,
highest-active-pos + window). Carries above `last` assumed 0.
tmp-reg : (>=last+1)-wide ancilla register at |0> for the carries lane.
bit-base : classical-bit base offset. Consumes [bit-base,
bit-base+last] via HMR during measurement-uncompute.
When *perpos-maj2* #t, each 3-CCX maj substitutes 2-CCX + 2-CX
ancilla-free majority (target ^= maj(acc,carry_in,kc) emitted as
ccx(acc,ci,target); cx(acc,ci); ccx(kc,ci,target); cx(acc,ci)).
Returns tmp-reg[0..last] to |0> via HMR + cz_if; acc-reg gets sum
updated; every kctrl unchanged."
(cond
((= n 0) #t)
((<= last -1) #t)
(else
(let ((maj2 *perpos-maj2*)
(ctrl-len (perpos-ctrls-length controls)))
;; Defensive: last must be < n.
(when (>= last n)
(error "cadd-per-position-controls-trunc!: last >= n"
last n))
;; Forward carry sweep, truncated at `last`.
;; carry_i = maj(acc_i, kctrl_i, carry_{i-1}) when both kc + ci
;; present; lower-order branches when one is absent.
(let loop ((i 0))
(when (<= i last)
(let* ((kc (perpos-ctrl-at controls i))
(carry-in? (> i 0)))
(cond
(kc
(let ((kc-reg (car kc))
(kc-idx (cdr kc)))
(cond
(carry-in?
;; *fold-maj1* (when on AND inputs distinct) wraps to
;; 4-CX + 1-CCX maj1 (saves 2 Toff/pos); else falls
;; through to maj2 (2-CCX + 2-CX) when caller set
;; maj2 #t; else 3-CCX baseline. Byte-identical when
;; *fold-maj1* off — emit-fold-majority!'s maj2/3-CCX
;; branches match the prior inline gate sequence.
(emit-fold-majority! c
acc-reg i ; a (acc[i])
kc-reg kc-idx ; k (kctrl_i)
tmp-reg (- i 1) ; ci (carry_{i-1})
tmp-reg i ; target (carry_i)
maj2))
(else
(gate-ccx! c acc-reg i kc-reg kc-idx tmp-reg i)))))
(carry-in?
(gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i))))
(loop (+ i 1))))
;; Sum bits: acc_i ^= kctrl_i ^ carry_{i-1}; carries above last 0.
(let loop ((i 0))
(when (< i n)
(let ((kc (perpos-ctrl-at controls i)))
(when kc
(gate-cx! c (car kc) (cdr kc) acc-reg i))
(when (and (> i 0) (<= (- i 1) last))
(gate-cx! c tmp-reg (- i 1) acc-reg i))
(loop (+ i 1)))))
;; Backward measurement-uncompute carries via HMR + cz_if.
(let loop-back ((i last))
(when (>= i 0)
(let ((m (+ bit-base i))
(kc (perpos-ctrl-at controls i))
(carry-in? (> i 0)))
(gate-hmr! c tmp-reg i m)
(cond
(kc
(let ((kc-reg (car kc))
(kc-idx (cdr kc)))
(gate-x! c acc-reg i)
(cond
(carry-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c acc-reg i tmp-reg (- i 1))
(gate-pop-cond! c)
(gate-x! c acc-reg i)
(gate-push-cond! c m)
(gate-cz! c kc-reg kc-idx tmp-reg (- i 1))
(gate-pop-cond! c))
(else
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-x! c acc-reg i)))))
(carry-in?
(gate-x! c acc-reg i)
(gate-push-cond! c m)
(gate-cz! c acc-reg i tmp-reg (- i 1))
(gate-pop-cond! c)
(gate-x! c acc-reg i))))
(loop-back (- i 1))))))))
(define (csub-per-position-controls-trunc!
c acc-reg n controls last tmp-reg bit-base)
"acc[0..n) -= sum_{i where ctrl_i present} (ctrl_i ? 2^i : 0),
borrow-tail truncated at index `last` (inclusive).
Port of HEAD csub_per_position_controls_trunc (const_arith.rs:737-814).
Same calling convention as cadd-per-position-controls-trunc!."
(cond
((= n 0) #t)
((<= last -1) #t)
(else
(let ((maj2 *perpos-maj2*))
(when (>= last n)
(error "csub-per-position-controls-trunc!: last >= n"
last n))
;; Forward borrow sweep, truncated at `last`.
(let loop ((i 0))
(when (<= i last)
(let* ((kc (perpos-ctrl-at controls i))
(borrow-in? (> i 0)))
(cond
(kc
(let ((kc-reg (car kc))
(kc-idx (cdr kc)))
(gate-x! c acc-reg i)
(cond
(borrow-in?
;; Symmetric to cadd-per-position-controls-trunc!.
;; X-sandwich on acc[i] inverts the carry-sense to
;; borrow; the inner maj is identical to the add
;; variant. *fold-maj1* fires here too when inputs
;; distinct. Byte-identical when *fold-maj1* off.
(emit-fold-majority! c
acc-reg i ; a (acc[i] with X-sandwich)
kc-reg kc-idx
tmp-reg (- i 1)
tmp-reg i
maj2))
(else
(gate-ccx! c acc-reg i kc-reg kc-idx tmp-reg i)))
(gate-x! c acc-reg i)))
(borrow-in?
(gate-x! c acc-reg i)
(gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)
(gate-x! c acc-reg i))))
(loop (+ i 1))))
;; Difference bits: acc_i ^= kctrl_i ^ borrow_{i-1}.
(let loop ((i 0))
(when (< i n)
(let ((kc (perpos-ctrl-at controls i)))
(when kc
(gate-cx! c (car kc) (cdr kc) acc-reg i))
(when (and (> i 0) (<= (- i 1) last))
(gate-cx! c tmp-reg (- i 1) acc-reg i))
(loop (+ i 1)))))
;; Backward measurement-uncompute borrows.
(let loop-back ((i last))
(when (>= i 0)
(let ((m (+ bit-base i))
(kc (perpos-ctrl-at controls i))
(borrow-in? (> i 0)))
(gate-hmr! c tmp-reg i m)
(cond
(kc
(let ((kc-reg (car kc))
(kc-idx (cdr kc)))
(cond
(borrow-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c acc-reg i tmp-reg (- i 1))
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c kc-reg kc-idx tmp-reg (- i 1))
(gate-pop-cond! c))
(else
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)))))
(borrow-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i tmp-reg (- i 1))
(gate-pop-cond! c))))
(loop-back (- i 1))))))))
;;; ── HEAD fold-substrate helpers (const_arith.rs:9-43, 911-987) ────
;;;
;;; Port of HEAD's fold-stage gate helpers. Used by both the baseline
;;; fused-fold ripple (when *fold-maj1* lifts maj inputs to maj1) and
;;; the freed-tail variant (which calls fold-postsum-carry-* directly
;;; for low-carry park / unpark).
;;;
;;; emit-fold-maj1! : 4-CX + 1-CCX majority on 4 DISTINCT qubits.
;;; Saves 2 Toff vs the 3-CCX baseline; needs all
;;; 4 inputs distinct (caller verifies).
;;; emit-fold-majority!: dispatch — fold-maj1 (if enabled + distinct),
;;; else maj2 (2 CCX + 2 CX), else 3-CCX baseline.
;;; fold-postsum-carry-phase-uncompute! : measurement-conditioned
;;; cz_if chain to un-park a parked carry (acc[i]
;;; ^= maj(...) inverse via cz_if instead of CCX).
;;; fold-postsum-carry-compute! : symmetric compute-from-acc
;;; pass when re-parking after the tail uncompute.
(define (fold-maj1-inputs-distinct? a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx)
"True iff all 4 (reg, idx) pairs are pairwise distinct. Matches HEAD's
maj1_inputs_distinct (const_arith.rs:4)."
(let ((pa (cons a-reg a-idx))
(pk (cons k-reg k-idx))
(pc (cons ci-reg ci-idx))
(pt (cons tgt-reg tgt-idx)))
(and (not (equal? pa pk))
(not (equal? pa pc))
(not (equal? pa pt))
(not (equal? pk pc))
(not (equal? pk pt))
(not (equal? pc pt)))))
(define (emit-fold-maj1! c a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx)
"4-CX + 1-CCX majority. tgt ^= maj(a, k, carry). HEAD const_arith.rs:13-21.
Caller MUST ensure the 4 inputs are pairwise distinct."
(gate-cx! c ci-reg ci-idx tgt-reg tgt-idx)
(gate-cx! c ci-reg ci-idx a-reg a-idx)
(gate-cx! c ci-reg ci-idx k-reg k-idx)
(gate-ccx! c a-reg a-idx k-reg k-idx tgt-reg tgt-idx)
(gate-cx! c ci-reg ci-idx k-reg k-idx)
(gate-cx! c ci-reg ci-idx a-reg a-idx))
(define (emit-fold-majority! c a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx maj2)
"Dispatch: if *fold-maj1* AND inputs distinct → maj1 (4 CX + 1 CCX);
else if maj2 → 2-CCX + 2-CX ancilla-free; else 3-CCX baseline.
Mirrors HEAD const_arith.rs:23-43 emit_fold_majority."
(cond
((and *fold-maj1*
(fold-maj1-inputs-distinct? a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx))
(emit-fold-maj1! c a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx))
(maj2
;; 2-CCX + 2-CX ancilla-free. tgt ^= maj(a, k, carry) via:
;; ccx(a, ci, tgt); cx(a, ci); ccx(k, ci, tgt); cx(a, ci)
(gate-ccx! c a-reg a-idx ci-reg ci-idx tgt-reg tgt-idx)
(gate-cx! c a-reg a-idx ci-reg ci-idx)
(gate-ccx! c k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx)
(gate-cx! c a-reg a-idx ci-reg ci-idx))
(else
;; 3-CCX baseline. tgt ^= maj(a, k, ci) = a·ci ⊕ k·a ⊕ k·ci.
(gate-ccx! c a-reg a-idx ci-reg ci-idx tgt-reg tgt-idx)
(gate-ccx! c k-reg k-idx a-reg a-idx tgt-reg tgt-idx)
(gate-ccx! c k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx))))
(define (fold-postsum-carry-phase-uncompute!
c acc-reg i kc-pair ci-pair m-bit is-add)
"Phase-only carry uncompute via cz_if on a measured classical bit.
acc-reg : accumulator quantum register.
i : current position (0..hi_delta).
kc-pair : (reg . idx) of position-i control, or #f.
ci-pair : (reg . idx) of carry_{i-1}, or #f (only at i=0).
m-bit : classical bit id holding HMR measurement of low[i].
is-add : #t for add, #f for sub (borrow).
Mirrors HEAD const_arith.rs:911-948 fold_postsum_carry_phase_uncompute."
(cond
(is-add
(cond
(kc-pair
(let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair)))
(gate-x! c acc-reg i)
(cond
(ci-pair
(let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
(gate-push-cond! c m-bit)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-push-cond! c m-bit)
(gate-cz! c acc-reg i ci-reg ci-idx)
(gate-pop-cond! c)
(gate-x! c acc-reg i)
(gate-push-cond! c m-bit)
(gate-cz! c kc-reg kc-idx ci-reg ci-idx)
(gate-pop-cond! c)))
(else
(gate-push-cond! c m-bit)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-x! c acc-reg i)))))
(ci-pair
(let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
(gate-x! c acc-reg i)
(gate-push-cond! c m-bit)
(gate-cz! c acc-reg i ci-reg ci-idx)
(gate-pop-cond! c)
(gate-x! c acc-reg i)))))
(else
(cond
(kc-pair
(let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair)))
(cond
(ci-pair
(let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
(gate-push-cond! c m-bit)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-push-cond! c m-bit)
(gate-cz! c acc-reg i ci-reg ci-idx)
(gate-pop-cond! c)
(gate-push-cond! c m-bit)
(gate-cz! c kc-reg kc-idx ci-reg ci-idx)
(gate-pop-cond! c)))
(else
(gate-push-cond! c m-bit)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)))))
(ci-pair
(let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
(gate-push-cond! c m-bit)
(gate-cz! c acc-reg i ci-reg ci-idx)
(gate-pop-cond! c)))))))
(define (fold-postsum-carry-compute!
c acc-reg i kc-pair ci-pair tgt-reg tgt-idx is-add)
"Symmetric Toffoli compute (re-park carry from post-sum acc). Used
after the tail uncompute to re-derive the parked low carries.
Mirrors HEAD const_arith.rs:950-987 fold_postsum_carry_compute."
(cond
(is-add
(cond
(kc-pair
(let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair)))
(gate-x! c acc-reg i)
(cond
(ci-pair
(let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
(gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx)
(gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx)
(gate-x! c acc-reg i)
(gate-ccx! c kc-reg kc-idx ci-reg ci-idx tgt-reg tgt-idx)))
(else
(gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx)
(gate-x! c acc-reg i)))))
(ci-pair
(let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
(gate-x! c acc-reg i)
(gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx)
(gate-x! c acc-reg i)))))
(else
(cond
(kc-pair
(let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair)))
(cond
(ci-pair
(let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
(gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx)
(gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx)
(gate-ccx! c kc-reg kc-idx ci-reg ci-idx tgt-reg tgt-idx)))
(else
(gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx)))))
(ci-pair
(let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair)))
(gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx)))))))
;;; ── sweep-fused-fold-v25 — cadd-2-controls-trunc-fast! ────────────
;;;
;;; HEAD reference: `compressed.rs:2193-2215` (forward fused fold body of
;;; `dialog_gcd_fused_double_y`) — single truncated ripple at width lsbs
;;; emitting δ = k1·ctrl1 + k2·ctrl2 via the 12-position per-position
;;; controls table mapped to bits {0,1,4,5,6,7,8,9,10,11, hi, hi+1} for a
;;; secp256k1-class pseudo-Mersenne c.
;;;
;;; What V2.5 saves vs V2's two `cadd-const!` calls:
;;;
;;; V2: cadd-const(v, lsbs, c, ctrl1) + cadd-const(v, lsbs, 2c, ctrl2)
;;; → 2 × full Solinas truncated ripple. ~62 Toff/call × 2.
;;;
;;; V2.5: derive 4 ancilla controls (h, xed, eord, n10) via 3 CCX + 6 CX,
;;; issue ONE per-position-controls truncated ripple at width lsbs,
;;; uncompute the 4 derived controls in reverse (6 CX + 1 CCX). The
;;; ripple itself emits ~62 Toff. Net: ~62 Toff/call + 4 CCX overhead.
;;;
;;; Save per mod-4x-inplace! call: ~62 - 4 Toff = ~58 Toff. ~50 % shift2-
;;; density × iters=258 ≈ 129 calls/shot → ~7-8k Toff saved per shot.
;;;
;;; CALLING CONVENTION:
;;;
;;; c : circuit/stream context.
;;; acc-reg : (>= lsbs)-wide quantum register (the v register).
;;; lsbs : slice width for the truncated ripple. Caller picks
;;; lsbs = min(n+1, padding + bit-length(2*c)) just like
;;; V2's cadd-const calls. last = min(lsbs - 2, hi + window)
;;; where hi = highest-set-bit(2*c) = bit-length(c).
;;; k1 : compile-time classical integer (V2.5 uses c, the
;;; pseudo-Mersenne complement 2^n - p).
;;; ctrl1-reg, ctrl1-idx : runtime qubit gating k1's addition.
;;; k2 : compile-time classical integer (V2.5 uses 2c).
;;; ctrl2-reg, ctrl2-idx : runtime qubit gating k2's addition.
;;; tmp-reg : (>= last+1)-wide ancilla register at |0> for carries.
;;; window : carry-tail safety bits past highest_set_bit(2*c).
;;; Caller passes *cadd-direct-window* (HEAD default 8).
;;; bit-base : classical-bit base offset; consumes
;;; [bit-base, bit-base+last] via HMR. Caller picks a
;;; non-colliding region (V2.5 uses *cadd-direct-bit-base*).
;;;
;;; Currently HARDCODED for HEAD's secp256k1 pseudo-Mersenne table
;;; (compressed.rs:2196-2210): k1 must have bits {0,4,6,7,8,9,hi} set and
;;; k2 = 2·k1 must have bits {1,5,7,8,9,10,hi+1}. Verified at build-time
;;; against (k1, k2). Errors when the pattern doesn't match — protects
;;; against silently emitting the wrong fold for a non-secp256k1 c.
;;;
;;; Returns tmp-reg[0..last] to |0> via HMR + cz_if (inside the
;;; per-position primitive); 4 derived-ctrl ancilla returned to |0> by
;;; reversed CX + CCX uncompute below; acc-reg gets δ added; both ctrl1
;;; and ctrl2 unchanged.
(define (cadd-2-controls-trunc-fast!
c acc-reg lsbs k1 ctrl1-reg ctrl1-idx k2 ctrl2-reg ctrl2-idx
tmp-reg window bit-base)
"acc[0..lsbs) += (ctrl1 ? k1 : 0) + (ctrl2 ? k2 : 0) in ONE truncated
carry sweep with per-position-controls. Hardcoded for HEAD's
secp256k1-class table where k2 == 2·k1 AND k1's bits sit at
{0,4,6,7,8,9,hi}. Errors otherwise.
*fold-maj1* / *perpos-maj2* threaded via emit-fold-majority! inside
cadd-per-position-controls-trunc!.
*fold-freed-tail* dispatches to cadd-fold-ripple-freed-tail!,
which owns the full h/xed/eord/n10 lifetime + split low/tail carry
lanes (HEAD const_arith.rs:1051-1267 fold_ripple_freed_tail_ed).
*fold-park-low-carries* only consumed inside freed-tail variant."
;; *fold-freed-tail* dispatch: routes the split-lane variant.
;; HEAD: free_ed gate implies base freed-tail (const_arith.rs:1064),
;; so we only consult *fold-freed-tail* here. *fold-freed-tail-ed*
;; remains a no-op until the e,d-extension wiring lands (HYP-6 §4a;
;; requires caller-supplied ovf1/ovf2/s2 live qubits, see ticket).
(cond
(*fold-freed-tail*
(let* ((kk1 (modulo k1 (expt 2 lsbs)))
(kk2 (modulo k2 (expt 2 lsbs))))
(cond
((= lsbs 0) #t)
((and (= kk1 0) (= kk2 0)) #t)
(else
(let ((hi (highest-set-bit kk1)))
(when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs))))
(error "cadd-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)"
k1 k2 lsbs))
(when (not (and (bit-set? kk1 0) (bit-set? kk1 4)
(bit-set? kk1 6) (bit-set? kk1 7)
(bit-set? kk1 8) (bit-set? kk1 9)
(bit-set? kk1 hi)))
(error "cadd-2-controls-trunc-fast!: k1 missing required bits"
k1 hi))
(when (<= lsbs (+ hi 1))
(error "cadd-2-controls-trunc-fast!: lsbs <= hi+1, no room"
lsbs hi))
(let* ((last (min (- lsbs 2) (+ (+ hi 1) window)))
(hi-delta (+ hi 1)))
;; HEAD const_arith.rs:1069 — freed-tail requires nonempty
;; high tail (last > hi-delta).
(when (<= last hi-delta)
(error "cadd-2-controls-trunc-fast!: *fold-freed-tail* needs last > hi+1"
last hi-delta))
(cadd-fold-ripple-freed-tail!
c acc-reg lsbs
ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx
last hi hi-delta #t bit-base)))))))
(else
(let* ((kk1 (modulo k1 (expt 2 lsbs)))
(kk2 (modulo k2 (expt 2 lsbs))))
(cond
((= lsbs 0) #t)
((and (= kk1 0) (= kk2 0)) #t)
(else
;; Validate HEAD table assumptions.
(let ((hi (highest-set-bit kk1)))
(when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs))))
(error "cadd-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)"
k1 k2 lsbs))
(when (not (and (bit-set? kk1 0)
(bit-set? kk1 4)
(bit-set? kk1 6)
(bit-set? kk1 7)
(bit-set? kk1 8)
(bit-set? kk1 9)
(bit-set? kk1 hi)))
(error "cadd-2-controls-trunc-fast!: k1 missing required bits"
k1 hi))
;; The table requires bit hi+1 to live inside lsbs (HEAD: hi=32
;; for secp256k1 → bit 33 inside lsbs ≥ 34). If lsbs ≤ hi+1 the
;; per-position table cannot place the high pair; fall back path
;; lives upstream at mod-4x-inplace! (V1 sequential).
(when (<= lsbs (+ hi 1))
(error "cadd-2-controls-trunc-fast!: lsbs <= hi+1, no room"
lsbs hi))
;; Derive 4 ancilla controls per HEAD compressed.rs:2169-2191.
;; "e" in HEAD ↔ ctrl1 (V2 carrier of k1·c).
;; "d" in HEAD ↔ ctrl2 (V2 carrier of k2·2c).
;; h = e & d (1 CCX)
;; xed = e ⊕ d (2 CX)
;; eord = (e ⊕ d) ⊕ h (2 CX; equals e | d)
;; n10 = d ⊕ h (2 CX; equals ¬e & d)
(let ((h '_v25-h)
(xed '_v25-xed)
(eord '_v25-eord)
(n10 '_v25-n10))
(alloc! c h 1)
(alloc! c xed 1)
(alloc! c eord 1)
(alloc! c n10 1)
;; h = ctrl1 & ctrl2
(gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
;; xed = ctrl1 ⊕ ctrl2
(gate-cx! c ctrl1-reg ctrl1-idx xed 0)
(gate-cx! c ctrl2-reg ctrl2-idx xed 0)
;; eord = xed ⊕ h
(gate-cx! c xed 0 eord 0)
(gate-cx! c h 0 eord 0)
;; n10 = ctrl2 ⊕ h
(gate-cx! c ctrl2-reg ctrl2-idx n10 0)
(gate-cx! c h 0 n10 0)
;; Build the per-position-controls list per HEAD's table.
;; bit 0: ctrl1 (k1 bit 0 = 1)
;; bit 1: ctrl2 (k2 bit 1 = 1)
;; bit 4: ctrl1 (k1 bit 4 = 1)
;; bit 5: ctrl2 (k2 bit 5 = 1)
;; bit 6: ctrl1 (k1 bit 6 = 1)
;; bit 7: xed (k1+k2 bit 7 = 2 → xor at 7, carry to 8)
;; bit 8: eord (k1+k2+carry bit 8)
;; bit 9: eord (k1+k2+carry bit 9)
;; bit 10: n10 (k2 bit 10 only)
;; bit 11: h (carry-fold absorption)
;; bit hi: ctrl1
;; bit hi+1: ctrl2
;; Positions not listed default to #f via perpos-ctrl-at.
(let* ((last (min (- lsbs 2)
(+ (+ hi 1) window)))
(controls (make-perpos-secp256k1-fold-controls
hi
(cons ctrl1-reg ctrl1-idx)
(cons ctrl2-reg ctrl2-idx)
(cons xed 0)
(cons eord 0)
(cons n10 0)
(cons h 0))))
(cadd-per-position-controls-trunc!
c acc-reg lsbs controls last tmp-reg bit-base))
;; Uncompute derived ancilla in EXACT reverse of derivation.
;; reverse n10 : (cx h n10) (cx ctrl2 n10)
(gate-cx! c h 0 n10 0)
(gate-cx! c ctrl2-reg ctrl2-idx n10 0)
;; reverse eord : (cx h eord) (cx xed eord)
(gate-cx! c h 0 eord 0)
(gate-cx! c xed 0 eord 0)
;; reverse xed : (cx ctrl2 xed) (cx ctrl1 xed)
(gate-cx! c ctrl2-reg ctrl2-idx xed 0)
(gate-cx! c ctrl1-reg ctrl1-idx xed 0)
;; reverse h : (ccx ctrl1 ctrl2 h)
(gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
(free! c n10)
(free! c eord)
(free! c xed)
(free! c h))))))))) ; closes (else ...) of *fold-freed-tail* dispatch
;;; Helper: build the 12-position controls list for HEAD's secp256k1 fold.
;;; The list length = hi + 2 (indices 0..hi+1 covered). Positions not in
;;; the table are #f (no control). hi = highest_set_bit(c) (= 32 for
;;; secp256k1). Per HEAD compressed.rs:2196-2210.
(define (make-perpos-secp256k1-fold-controls hi e-pair d-pair xed-pair
eord-pair n10-pair h-pair)
"Return list of length (hi + 2) for the per-position-controls fold of
δ = k1·e + k2·d under HEAD's secp256k1 table."
;; Walk i = 0..(hi+1) and append the right pair (or #f).
(let loop ((i 0) (acc '()))
(cond
((> i (+ hi 1))
(reverse acc))
(else
(let ((entry
(cond
((= i 0) e-pair)
((= i 1) d-pair)
((= i 4) e-pair)
((= i 5) d-pair)
((= i 6) e-pair)
((= i 7) xed-pair)
((= i 8) eord-pair)
((= i 9) eord-pair)
((= i 10) n10-pair)
((= i 11) h-pair)
((= i hi) e-pair)
((= i (+ hi 1)) d-pair)
(else #f))))
(loop (+ i 1) (cons entry acc)))))))
;;; ── cadd-fold-ripple-freed-tail! — split-lane fused-fold ripple ───
;;;
;;; Port of HEAD const_arith.rs:1051-1267 fold_ripple_freed_tail_ed.
;;; Splits the carry lane into `_ft-low[0..=hi-delta]` (parked across the
;;; active region; lifetime spans the full call) + `_ft-tail[0..tail-len)`
;;; (allocated AFTER the four derived controls h/xed/eord/n10 are freed
;;; mid-ripple, freed BEFORE they are re-derived). Net wide-tail
;;; high-water drops by 4 ancillae vs the unsplit ripple (HEAD §6.6).
;;;
;;; PORT STATUS (2026-06-13): WIRED. The primitive owns the FULL
;;; ancilla lifetime — caller supplies only ctrl1, ctrl2, acc-reg,
;;; lsbs, last, hi, hi-delta, is-add, bit-base. Returns acc += δ
;;; (is-add=#t) or acc -= δ (is-add=#f), ctrl1/ctrl2 unchanged,
;;; every ancilla freed.
;;;
;;; e,d-extension (*fold-freed-tail-ed*) STRUCTURAL NO-OP under lumbda.
;;; HEAD's free_ed pass (const_arith.rs:1162-1172) frees the separate
;;; e,d copy qubits that HEAD allocates from `(ovf1, ovf2, s2)` (see
;;; compressed.rs:3260-3271 `d = ovf1 & s2; e = ovf1 ^ d ^ ovf2`).
;;; Lumbda's `cadd-2-controls-trunc-fast!` dispatcher binds e↔ctrl1
;;; and d↔ctrl2 DIRECTLY (see docstring at line 2750-2755) — under
;;; the s2=1 classical specialization (lumbda's mod-4x-inplace! IS
;;; the K=2 shift2=1 specialization; s2 is classical-true & not a
;;; qubit), HEAD's e,d-copy alloc collapses to `e = ovf2, d = ovf1`
;;; and lumbda skips the copy alloc entirely. The -2 ancillae HEAD
;;; reports across the wide tail are already-banked at the substrate
;;; level: lumbda's freed-tail body has no separate e,d qubits to
;;; free in step 3b. See test-fold-freed-tail-ed-port.lsp for the
;;; positive-control reducer proving flag-ON byte-identical to
;;; flag-OFF + same peak-qubits + same toffoli count.
;;;
;;; *fold-park-low-carries* wired below: when > 0, the lowest `park`
;;; carries in `_ft-low` are measurement-uncomputed before tail alloc
;;; and recomputed before the low uncompute pass — drops high-water by
;;; `park` more qubits at cost of `park` HMR + cz_if (phase-EXACT,
;;; 0 Toffoli).
;;;
;;; CALLING CONVENTION (note: shape differs from the original stub —
;;; caller no longer supplies pre-derived h/xed/eord/n10):
;;;
;;; c : circuit context.
;;; acc-reg : (>=lsbs)-wide quantum register.
;;; lsbs : slice width (acc.len() in HEAD).
;;; ctrl1-reg ctrl1-idx : "e" in HEAD (k1·c carrier).
;;; ctrl2-reg ctrl2-idx : "d" in HEAD (k2·2c carrier).
;;; last : inclusive carry-truncation index. > hi-delta.
;;; hi : highest-set-bit(k1) (32 for secp256k1).
;;; hi-delta : hi + 1 (33 for secp256k1). HEAD's hi_delta.
;;; is-add : #t for cadd; #f for csub (borrow).
;;; bit-base : classical-bit base. Consumes
;;; [bit-base, bit-base + last + 1] (last+1 carry
;;; HMRs + 1 for the h measurement clear).
;;;
;;; CLASSICAL-BIT MAP (deterministic — caller picks bit-base; primitive
;;; uses the following offsets):
;;; bit-base + i : HMR target for carry low[i] (0 <= i <= hi-delta)
;;; bit-base + i : HMR target for carry tail[i - hi-delta - 1]
;;; (hi-delta < i <= last) — same i indexing
;;; bit-base + last+1 : HMR target for the h free-measurement
;;; bit-base + last+2 + i : HMR target for the park-low pass
;;; (only consumed when *fold-park-low-carries* > 0)
;;; Caller must reserve [bit-base, bit-base + last + 1 + park-low + 1).
(define (cadd-fold-ripple-freed-tail!
c acc-reg lsbs ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx
last hi hi-delta is-add bit-base)
"Split-lane fused-fold ripple. Owns full ancilla lifetime; caller
passes only the two base controls + arithmetic params.
HEAD const_arith.rs:1019-1267 fold_ripple_freed_tail_ed."
;; Sanity guards (mirror HEAD debug_assert!).
(when (>= last lsbs)
(error "cadd-fold-ripple-freed-tail!: last >= lsbs" last lsbs))
(when (<= last hi-delta)
(error "cadd-fold-ripple-freed-tail!: last <= hi-delta (no tail)"
last hi-delta))
(let* ((maj2 *perpos-maj2*)
(park-low (let ((p *fold-park-low-carries*))
(cond ((< p 0) 0)
((> p hi-delta) hi-delta)
(else p))))
;; Named ancilla — distinct from caller's tmp-reg so dispatcher
;; can reuse the unsplit-path tmp-reg without clobber risk.
(h '_ft-h)
(xed '_ft-xed)
(eord '_ft-eord)
(n10 '_ft-n10)
(low '_ft-low)
(tail '_ft-tail)
(bit-h (+ bit-base last 1)))
;; ── 0a. Derive h/xed/eord/n10 from ctrl1, ctrl2 (HEAD compressed.rs
;; :2169-2191; identical to dispatcher's pre-derive in the unsplit
;; path).
(alloc! c h 1)
(alloc! c xed 1)
(alloc! c eord 1)
(alloc! c n10 1)
(gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
(gate-cx! c ctrl1-reg ctrl1-idx xed 0)
(gate-cx! c ctrl2-reg ctrl2-idx xed 0)
(gate-cx! c xed 0 eord 0)
(gate-cx! c h 0 eord 0)
(gate-cx! c ctrl2-reg ctrl2-idx n10 0)
(gate-cx! c h 0 n10 0)
;; ── 0b. Build the per-position controls list (length hi-delta+1).
;; HEAD: controls[i] = Some(qubit) at table positions, None elsewhere;
;; controls.get(i).copied().flatten() at i > hi-delta returns None.
;; We re-use make-perpos-secp256k1-fold-controls (length = hi+2 =
;; hi-delta+1) — perpos-ctrl-at returns #f for any i beyond.
(let* ((controls (make-perpos-secp256k1-fold-controls
hi
(cons ctrl1-reg ctrl1-idx) ; e
(cons ctrl2-reg ctrl2-idx) ; d
(cons xed 0)
(cons eord 0)
(cons n10 0)
(cons h 0)))
(tail-len (- last hi-delta))
(kctrl (lambda (i) (perpos-ctrl-at controls i))))
;; Allocate the LOW carry lane first (controls live across active region).
(alloc! c low (+ hi-delta 1))
;; ── 1. Active region carry sweep [0..=hi-delta] ────────────────
;; HEAD const_arith.rs:1082-1108.
(let loop ((i 0))
(when (<= i hi-delta)
(let ((kc (kctrl i))
(carry-in? (> i 0)))
(cond
(is-add
(cond
(kc
(let ((kc-reg (car kc)) (kc-idx (cdr kc)))
(cond
(carry-in?
(emit-fold-majority! c
acc-reg i kc-reg kc-idx low (- i 1) low i maj2))
(else
(gate-ccx! c acc-reg i kc-reg kc-idx low i)))))
(carry-in?
(gate-ccx! c acc-reg i low (- i 1) low i))))
(else
(cond
(kc
(let ((kc-reg (car kc)) (kc-idx (cdr kc)))
(gate-x! c acc-reg i)
(cond
(carry-in?
(emit-fold-majority! c
acc-reg i kc-reg kc-idx low (- i 1) low i maj2))
(else
(gate-ccx! c acc-reg i kc-reg kc-idx low i)))
(gate-x! c acc-reg i)))
(carry-in?
(gate-x! c acc-reg i)
(gate-ccx! c acc-reg i low (- i 1) low i)
(gate-x! c acc-reg i))))))
(loop (+ i 1))))
;; ── 2. Low sum bits [0..=hi-delta]: acc_i ^= k_i ^ carry_{i-1} ─
;; HEAD const_arith.rs:1109-1119.
(let loop ((i 0))
(when (<= i hi-delta)
(let ((kc (kctrl i)))
(when kc
(gate-cx! c (car kc) (cdr kc) acc-reg i))
(when (> i 0)
(gate-cx! c low (- i 1) acc-reg i)))
(loop (+ i 1))))
;; ── 2b. Park the lowest `park-low` carries via HMR + cz_if ─────
;; HEAD const_arith.rs:1126-1134. Walks i = park_low-1 down to 0.
;; Uses bits [bit-base+last+2, bit-base+last+1+park-low] (disjoint
;; from the step-5/step-7 [bit-base, bit-base+last] range AND from
;; the bit-base+last+1 h-clear slot). In lumbda the parked low[i]
;; qubits stay allocated (no per-slot free); step 6b's CCX
;; recompute restores their carry value before step 7's full HMR
;; uncompute sweeps them too — so the phase from THIS measurement
;; commutes through but the bit slot must not collide with a later
;; HMR or the simulator double-measures into the same classical bit.
(when (> park-low 0)
(let loop ((i (- park-low 1)))
(when (>= i 0)
(let ((m (+ bit-base last 2 i))
(kc (kctrl i))
(carry-in? (> i 0)))
(gate-hmr! c low i m)
;; fold-postsum-carry-phase-uncompute (HEAD const_arith.rs:911)
;; acc[i] ^= maj(...) via cz_if chain conditional on the HMR bit.
(cond
(is-add
(cond
(kc
(let ((kc-reg (car kc)) (kc-idx (cdr kc)))
(gate-x! c acc-reg i)
(cond
(carry-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c acc-reg i low (- i 1))
(gate-pop-cond! c)
(gate-x! c acc-reg i)
(gate-push-cond! c m)
(gate-cz! c kc-reg kc-idx low (- i 1))
(gate-pop-cond! c))
(else
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-x! c acc-reg i)))))
(carry-in?
(gate-x! c acc-reg i)
(gate-push-cond! c m)
(gate-cz! c acc-reg i low (- i 1))
(gate-pop-cond! c)
(gate-x! c acc-reg i))))
(else
(cond
(kc
(let ((kc-reg (car kc)) (kc-idx (cdr kc)))
(cond
(carry-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c acc-reg i low (- i 1))
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c kc-reg kc-idx low (- i 1))
(gate-pop-cond! c))
(else
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)))))
(carry-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i low (- i 1))
(gate-pop-cond! c))))))
(loop (- i 1)))))
;; ── 3. Free h, xed, eord, n10 BEFORE allocating the wide tail ──
;; HEAD const_arith.rs:1140-1152. Uncompute in reverse derivation
;; order, then measurement-clear h.
(gate-cx! c h 0 n10 0)
(gate-cx! c ctrl2-reg ctrl2-idx n10 0)
(gate-cx! c h 0 eord 0)
(gate-cx! c xed 0 eord 0)
(gate-cx! c ctrl2-reg ctrl2-idx xed 0)
(gate-cx! c ctrl1-reg ctrl1-idx xed 0)
(free! c n10)
(free! c eord)
(free! c xed)
;; h cleared via HMR + cz_if(ctrl1, ctrl2, mh) — phase-exact AND-clear
;; (h = ctrl1 & ctrl2 still holds; cz_if undoes the phase when ctrl1
;; AND ctrl2, restoring |0>). HEAD const_arith.rs:1149-1152.
(gate-hmr! c h 0 bit-h)
(gate-push-cond! c bit-h)
(gate-cz! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx)
(gate-pop-cond! c)
(free! c h)
;; ── 4. Allocate the wide tail (4 derived controls now released) ─
(alloc! c tail tail-len)
;; ── 4a. High-tail carry generation (hi-delta, last]: pure
;; propagation from ORIGINAL acc (acc[hi-delta+1..] untouched
;; by step 2). HEAD const_arith.rs:1188-1197.
;; carry-in for i = hi-delta+1 is low[hi-delta]; subsequent carries
;; are in tail[(i - hi-delta - 1) - 1] = tail[i - hi-delta - 2].
(let loop ((i (+ hi-delta 1)))
(when (<= i last)
(let ((tgt-idx (- i hi-delta 1))
(ci-tail? (> i (+ hi-delta 1))))
(cond
(is-add
(cond
(ci-tail?
(gate-ccx! c acc-reg i tail (- tgt-idx 1) tail tgt-idx))
(else
(gate-ccx! c acc-reg i low hi-delta tail tgt-idx))))
(else
(gate-x! c acc-reg i)
(cond
(ci-tail?
(gate-ccx! c acc-reg i tail (- tgt-idx 1) tail tgt-idx))
(else
(gate-ccx! c acc-reg i low hi-delta tail tgt-idx)))
(gate-x! c acc-reg i))))
(loop (+ i 1))))
;; ── 4b. High sum bits (hi-delta, lsbs) (k=0, control-free):
;; acc_i ^= carry_{i-1}. HEAD const_arith.rs:1199-1203.
(let loop ((i (+ hi-delta 1)))
(when (< i lsbs)
(when (<= (- i 1) last)
(let ((src-i (- i 1)))
(cond
((<= src-i hi-delta)
(gate-cx! c low src-i acc-reg i))
(else
(gate-cx! c tail (- src-i hi-delta 1) acc-reg i)))))
(loop (+ i 1))))
;; ── 5. Reverse uncompute the TAIL carries first (control-free,
;; high → low) so the wide lane shrinks before ctrl recompute.
;; HEAD const_arith.rs:1207-1219.
(let loop ((i last))
(when (> i hi-delta)
(let ((m (+ bit-base i))
(tgt-idx (- i hi-delta 1))
(ci-tail? (> i (+ hi-delta 1))))
(gate-hmr! c tail tgt-idx m)
(cond
(is-add
(gate-x! c acc-reg i)
(gate-push-cond! c m)
(cond
(ci-tail?
(gate-cz! c acc-reg i tail (- tgt-idx 1)))
(else
(gate-cz! c acc-reg i low hi-delta)))
(gate-pop-cond! c)
(gate-x! c acc-reg i))
(else
(gate-push-cond! c m)
(cond
(ci-tail?
(gate-cz! c acc-reg i tail (- tgt-idx 1)))
(else
(gate-cz! c acc-reg i low hi-delta)))
(gate-pop-cond! c))))
(loop (- i 1))))
(free! c tail)
;; ── 6. Re-derive h, xed, eord, n10 (same gate sequence as
;; step 0a) — for the low uncompute pass. They stay live on
;; return (matches HEAD's `// h, xed, eord, n10 are left LIVE`
;; comment at const_arith.rs:1265).
(alloc! c h 1)
(alloc! c xed 1)
(alloc! c eord 1)
(alloc! c n10 1)
(gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
(gate-cx! c ctrl1-reg ctrl1-idx xed 0)
(gate-cx! c ctrl2-reg ctrl2-idx xed 0)
(gate-cx! c xed 0 eord 0)
(gate-cx! c h 0 eord 0)
(gate-cx! c ctrl2-reg ctrl2-idx n10 0)
(gate-cx! c h 0 n10 0)
;; ── 6b. Park-low recompute: rebuild parked carries via CCX
;; (fold-postsum-carry-compute, HEAD const_arith.rs:1248-1254).
(when (> park-low 0)
(let loop ((i 0))
(when (< i park-low)
(let ((kc (kctrl i))
(carry-in? (> i 0)))
(cond
(is-add
(cond
(kc
(let ((kc-reg (car kc)) (kc-idx (cdr kc)))
(gate-x! c acc-reg i)
(cond
(carry-in?
(gate-ccx! c acc-reg i kc-reg kc-idx low i)
(gate-ccx! c acc-reg i low (- i 1) low i)
(gate-x! c acc-reg i)
(gate-ccx! c kc-reg kc-idx low (- i 1) low i))
(else
(gate-ccx! c acc-reg i kc-reg kc-idx low i)
(gate-x! c acc-reg i)))))
(carry-in?
(gate-x! c acc-reg i)
(gate-ccx! c acc-reg i low (- i 1) low i)
(gate-x! c acc-reg i))))
(else
(cond
(kc
(let ((kc-reg (car kc)) (kc-idx (cdr kc)))
(cond
(carry-in?
(gate-ccx! c acc-reg i kc-reg kc-idx low i)
(gate-ccx! c acc-reg i low (- i 1) low i)
(gate-ccx! c kc-reg kc-idx low (- i 1) low i))
(else
(gate-ccx! c acc-reg i kc-reg kc-idx low i)))))
(carry-in?
(gate-ccx! c acc-reg i low (- i 1) low i))))))
(loop (+ i 1)))))
;; ── 7. Reverse uncompute the active-region carries [0..=hi-delta].
;; HEAD const_arith.rs:1257-1263 walks i = hi_delta down to 0;
;; HEAD's per-slot free at step 2b means the parked slots are
;; reacquired by step 6b before this pass. In lumbda we don't
;; per-slot free, so the parked low[i] qubits were never released
;; — but step 2b HMR'd them to |0> and step 6b recomputed them to
;; the original carry value, so the sweep below is well-defined
;; on ALL i in [0, hi-delta] without skipping.
(let loop ((i hi-delta))
(when (>= i 0)
(let ((m (+ bit-base i))
(kc (kctrl i))
(carry-in? (> i 0)))
(gate-hmr! c low i m)
(cond
(is-add
(cond
(kc
(let ((kc-reg (car kc)) (kc-idx (cdr kc)))
(gate-x! c acc-reg i)
(cond
(carry-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c acc-reg i low (- i 1))
(gate-pop-cond! c)
(gate-x! c acc-reg i)
(gate-push-cond! c m)
(gate-cz! c kc-reg kc-idx low (- i 1))
(gate-pop-cond! c))
(else
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-x! c acc-reg i)))))
(carry-in?
(gate-x! c acc-reg i)
(gate-push-cond! c m)
(gate-cz! c acc-reg i low (- i 1))
(gate-pop-cond! c)
(gate-x! c acc-reg i))))
(else
(cond
(kc
(let ((kc-reg (car kc)) (kc-idx (cdr kc)))
(cond
(carry-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c acc-reg i low (- i 1))
(gate-pop-cond! c)
(gate-push-cond! c m)
(gate-cz! c kc-reg kc-idx low (- i 1))
(gate-pop-cond! c))
(else
(gate-push-cond! c m)
(gate-cz! c acc-reg i kc-reg kc-idx)
(gate-pop-cond! c)))))
(carry-in?
(gate-push-cond! c m)
(gate-cz! c acc-reg i low (- i 1))
(gate-pop-cond! c))))))
(loop (- i 1))))
(free! c low)
;; ── 8. Uncompute h/xed/eord/n10 in reverse derivation (same
;; teardown the unsplit-path dispatcher emits after its
;; cadd-per-position-controls-trunc! call). HEAD: caller's
;; "normal derived-control uncompute block runs next"
;; (const_arith.rs:1265) — we run it here so the call is
;; self-contained (matches the byte-identity contract of the
;; default-OFF flag).
(gate-cx! c h 0 n10 0)
(gate-cx! c ctrl2-reg ctrl2-idx n10 0)
(gate-cx! c h 0 eord 0)
(gate-cx! c xed 0 eord 0)
(gate-cx! c ctrl2-reg ctrl2-idx xed 0)
(gate-cx! c ctrl1-reg ctrl1-idx xed 0)
(gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
(free! c n10)
(free! c eord)
(free! c xed)
(free! c h))))
(define (cadd-const! c acc-reg n k ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg)
"acc += (ctrl ? k : 0) mod 2^n. Dispatches to direct sparse path when
*cadd-direct-trunc-fast* on; else cload + cuccaro-add."
(let ((kk (modulo k (expt 2 n))))
(cond
((and *cadd-direct-trunc-fast* (> n 1) (> kk 0))
(cadd-nbit-const-direct-trunc-fast!
c acc-reg n kk ctrl-reg ctrl-idx tmp-reg
*cadd-direct-window* (cdtf-alloc-bit-base! n)))
(else
(cload-const! c ctrl-reg ctrl-idx tmp-reg n kk)
(cuccaro-add! c tmp-reg acc-reg cin-reg cin-idx n)
(cunload-const! c ctrl-reg ctrl-idx tmp-reg n kk)))))
;;; ── Controlled lazy mod-double / mod-halve (sweep-cmod-inplace-lazy)
;;;
;;; HEAD modular.rs:823 cmod_double_inplace_lazy
;;; modular.rs:847 cmod_halve_inplace_lazy
;;;
;;; Closes AUDIT §6 rows 260-261.
;;;
;;; Controlled (ctrl) form of mod_double_inplace_fast (Solinas reduction,
;;; lazy [0,2^n) coset rep, same carry-trunc window). Identity when
;;; ctrl=0. Used by the K=2 prototype's conditional 2nd double so it
;;; composes correctly with the uncontrolled mod_double_inplace_fast
;;; in the apply path.
;;;
;;; Algorithm (HEAD modular.rs:823-842):
;;; 1. cswap(ctrl, v[n-1], ovf)
;;; 2. for i in (0..n-1).rev(): cswap(ctrl, v[i], v[i+1])
;;; 3. c := 2^n - p (mod 2^n)
;;; 4. cadd_nbit_const_*(v, c, ovf) — dispatched by
;;; *double-carry-trunc-window* / *cadd-direct-trunc-fast* flags
;;; 5. ccx(ctrl, v[0], ovf) — clear ovf via parity == top-bit
;;;
;;; Halve is symmetric inverse: ovf clear first, csub instead of cadd,
;;; reverse cswap order.
;;;
;;; Caller responsibilities:
;;; v-reg: data register width n; modified in place
;;; ctrl-reg/ctrl-idx: read-only control bit
;;; ovf-reg/ovf-idx: clean |0> ancilla; restored to |0> on exit
;;; cin-reg/cin-idx + tmp-reg: scratch for the inner cadd-const!
;;; (must be clean; restored)
;;; p: classical prime modulus
(define (cmod-double-inplace-lazy!
c v-reg n p ctrl-reg ctrl-idx
ovf-reg ovf-idx cin-reg cin-idx tmp-reg)
"Port of HEAD cmod_double_inplace_lazy (modular.rs:823).
v := (ctrl ? (2*v) mod p : v). Lazy coset rep — caller responsible
for any final normalization. Identity when ctrl=0."
;; Shift v left by 1 via cswap chain (only if ctrl=1).
(gate-cswap! c ctrl-reg ctrl-idx v-reg (- n 1) ovf-reg ovf-idx)
(let loop ((i (- n 2)))
(when (>= i 0)
(gate-cswap! c ctrl-reg ctrl-idx v-reg i v-reg (+ i 1))
(loop (- i 1))))
;; Solinas correction: add (2^n - p) when ctrl=1.
(let ((corr (modulo (- (expt 2 n) p) (expt 2 n))))
(cadd-const! c v-reg n corr
ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg))
;; Clear ovf: result parity = old top-bit = ovf (gated by ctrl).
(gate-ccx! c ctrl-reg ctrl-idx v-reg 0 ovf-reg ovf-idx))
(define (cmod-halve-inplace-lazy!
c v-reg n p ctrl-reg ctrl-idx
ovf-reg ovf-idx cin-reg cin-idx tmp-reg)
"Port of HEAD cmod_halve_inplace_lazy (modular.rs:847). Inverse of
cmod-double-inplace-lazy!. Identity when ctrl=0."
;; Re-establish ovf bit from current v[0] (gated by ctrl).
(gate-ccx! c ctrl-reg ctrl-idx v-reg 0 ovf-reg ovf-idx)
;; Inverse Solinas correction: subtract (2^n - p) when ctrl=1.
(let ((corr (modulo (- (expt 2 n) p) (expt 2 n))))
(csub-const! c v-reg n corr
ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg))
;; Inverse shift: reverse cswap order.
(let loop ((i 0))
(when (< i (- n 1))
(gate-cswap! c ctrl-reg ctrl-idx v-reg i v-reg (+ i 1))
(loop (+ i 1))))
(gate-cswap! c ctrl-reg ctrl-idx v-reg (- n 1) ovf-reg ovf-idx))
;;; ── reversible mod-sub (hand-rolled inverse of mod-add!) ───────
;;;
;;; Upstream mod_sub_qq emits the gate-level inverse of mod_add_qq via an
;;; emit_inverse helper. We don't have emit-inverse yet, so we hand-roll:
;;; walk mod-add!'s 8 steps in REVERSE order, replacing each step with
;;; its gate-level inverse. Self-inverse steps (CX, X, cmp-lt-into) emit
;;; unchanged; add-const flips to sub-const; csub-const flips to cadd-const;
;;; cuccaro-add flips to cuccaro-sub.
(define (mod-sub-inplace-pseudo-mersenne!
c a-reg acc-reg n+1 p pmersenne-f
cin-reg cin-idx tmp-reg flag-reg flag-idx)
"Gate-level inverse of mod-add-inplace-pseudo-mersenne!.
acc := (acc - a) mod p under the pseudo-Mersenne approximation.
ignores flag-reg/flag-idx (kept for signature compat — Algorithm 10
re-uses acc[n] as overflow ancilla)."
(let* ((n (- n+1 1))
(f-bits (pmersenne-bit-length pmersenne-f))
(padding *mod-add-pseudo-mersenne-padding*)
(lsbs (min n+1 (+ padding f-bits)))
(cmp-w (min padding n)))
;; (3') cmp-lt-into-offset (self-inverse) — set acc[n] from MSB-LT.
;; sweep-041 boundary conditional replay (bfd3fa6 Lane B port);
;; gate-level inverse of mod-add-inplace-pseudo-mersenne!'s step
;; (3). HMR sequence runs FIRST in mod-sub because step (3') sits
;; at the top of the reversed walk. Same bit-id layout as forward
;; path so phase reuses (* 5 n+1).
(cond
(*dgcd-apply-boundary-conditional-replay*
(let ((phase-bit (* 5 n+1)))
(gate-hmr! c acc-reg n phase-bit)
(cmp-lt-phase-conditioned-with-cin!
c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
cin-reg cin-idx
acc-reg n
phase-bit
tmp-reg 0 (* 3 n+1))))
(*cuccaro-use-borrowed*
(cmp-lt-into-fast-offset!
c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
acc-reg n cin-reg cin-idx
tmp-reg 0 (* 3 n+1)))
(else
(cmp-lt-into-offset!
c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w
acc-reg n cin-reg cin-idx)))
;; (2') csub-const f (inverse of cadd-const f).
(csub-const! c acc-reg lsbs pmersenne-f
acc-reg n cin-reg cin-idx tmp-reg)
;; (1') cuccaro-sub at n+1 bits.
;; sweep-windowed-wiring: mirror of mod-add-inplace-pseudo-mersenne!
;; step (1) windowed dispatch.
(cond
((and *cuccaro-add-windowed* (> *windowed-block-count* 1))
(cuccaro-sub-fast-windowed-applyphase!
c a-reg acc-reg cin-reg cin-idx n+1
*windowed-block-count*
'pmsub-windowed (* 7 n+1)))
(*cuccaro-use-borrowed*
(cuccaro-sub-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1
tmp-reg 0 (* 2 n+1)))
(else
(cuccaro-sub! c a-reg acc-reg cin-reg cin-idx n+1)))))
(define (mod-sub! c a-reg acc-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
"acc := (acc - a) mod p. Same calling convention as mod-add!:
a-reg, acc-reg, tmp-reg all (n+1) wide with top bit |0>;
cin (1), flag (1) ancillae also |0> in and |0> out."
(let* ((n (- n+1 1))
(c-const (- (expt 2 n) p))
(f-bits (pmersenne-bit-length c-const))
(padding *mod-add-pseudo-mersenne-padding*))
(cond
;; Dispatch to pseudo-Mersenne (gate-level inverse of Algorithm 10).
;;
;; 2026-06-12 — DISABLED. Gate-level inverse of buggy
;; mod-add-inplace-pseudo-mersenne! inherits the same boundary
;; defect. Standard mod-sub! body (else branch) mirrors the
;; reversed standard mod-add!. See commit 5e6e3af + this commit
;; for full bug analysis.
;;
;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on,
;; mod-add-alg-11-sub-safe? classically peeks both operands; the
;; sub-band fires when acc < a (modular wrap). Routes
;; pseudo-Mersenne only on safe inputs.
((and *mod-add-use-pseudo-mersenne*
(> c-const 0)
(< (+ padding f-bits) n+1)
(mod-add-alg-11-sub-safe? c a-reg acc-reg n+1 p))
(mod-sub-inplace-pseudo-mersenne!
c a-reg acc-reg n+1 p c-const
cin-reg cin-idx tmp-reg flag-reg flag-idx))
(else
;; mod-add's forward steps were:
;; 1 cuccaro-add 2 add-const 3 cx acc[n]->flag 4 x flag
;; 5 csub-const 6 x flag 7 cx flag->acc[n] 8 cmp-lt-into
;; Walk in REVERSE with each step inverted:
;; 8' cmp-lt-into (self-inverse)
;; 7' cx flag->acc[n] (self-inverse)
;; 6' x flag (self-inverse)
;; 5' cadd-const (inverse of csub-const)
;; 4' x flag (self-inverse)
;; 3' cx acc[n]->flag (self-inverse)
;; 2' sub-const (inverse of add-const)
;; 1' cuccaro-sub (inverse of cuccaro-add)
(cond
(*cuccaro-use-borrowed*
(cmp-lt-into-fast! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx
tmp-reg 0 (* 3 n+1)))
(else
(cmp-lt-into! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx)))
(gate-cx! c flag-reg flag-idx acc-reg n)
(gate-x! c flag-reg flag-idx)
(cadd-const! c acc-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg)
(gate-x! c flag-reg flag-idx)
(gate-cx! c acc-reg n flag-reg flag-idx)
(sub-const! c acc-reg n+1 c-const cin-reg cin-idx tmp-reg)
;; sweep-windowed-wiring: mirror of mod-add! step (1) wiring.
(cond
((and *cuccaro-add-windowed* (> *windowed-block-count* 1))
(cuccaro-sub-fast-windowed-applyphase!
c a-reg acc-reg cin-reg cin-idx n+1
*windowed-block-count*
'mod-sub-windowed (* 7 n+1)))
(*cuccaro-use-borrowed*
(cuccaro-sub-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1
tmp-reg 0 (* 2 n+1)))
(else
(cuccaro-sub! c a-reg acc-reg cin-reg cin-idx n+1)))))))
;;; ── mod-{add,add-double,sub}-qb! — quantum + classical-bit adders ──
;;;
;;; Port of HEAD modular.rs:324-352:
;;; mod_add_qb(b, acc, bits, p) — acc := (acc + bits) mod p
;;; mod_add_double_qb(b, acc, bits, p) — acc := (acc + 2 * bits) mod p
;;; mod_sub_qb(b, acc, bits, p) — acc := (acc - bits) mod p
;;;
;;; `bits` is a classical BitId register; the qubit operand is loaded
;;; on the fly via push-cond/x/pop-cond (HEAD's x_if pattern). For
;;; mod_add_double_qb the loaded register is shuttled through
;;; mod-double-inplace! → mod-add! → mod-halve-inplace! so a single
;;; classical load + unload covers the 2x scaling.
;;;
;;; Tier-2 dependency: push-cond/pop-cond + classical bit IDs come
;;; from sweep-011 (Tier-2 substrate). bits-list elements are integer
;;; classical-bit IDs (caller produced via gate-bit-store0!/1! or
;;; HMR). bits-list length = n+1 = register width.
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; these yet. Closes COLLAB §1.6 (= AUDIT §6 modular.rs rows 324/331/341).
(define (load-bits-into-qubits!
c bits-list q-reg n)
;; For each i in 0..n: x_if(q-reg[i], bits-list[i]). HEAD adder.rs:366
;; algorithm. Caller-supplied q-reg (alloc'd at |0>); bits-list of
;; integer classical-bit IDs.
(let loop ((i 0) (rest bits-list))
(when (and (< i n) (not (null? rest)))
(gate-push-cond! c (car rest))
(gate-x! c q-reg i)
(gate-pop-cond! c)
(loop (+ i 1) (cdr rest)))))
(define (unload-bits-from-qubits!
c bits-list q-reg n)
;; Self-inverse of load-bits-into-qubits!; x_if is its own inverse.
;; HEAD adder.rs:376.
(load-bits-into-qubits! c bits-list q-reg n))
(define (mod-add-qb!
c acc-reg n+1 bits-list p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
;; acc := (acc + bits) mod p. Inline-allocs a transient register
;; for the loaded bits, runs mod-add!, unloads + frees.
(alloc! c 'mod-qb-a n+1)
(load-bits-into-qubits! c bits-list 'mod-qb-a n+1)
(mod-add! c 'mod-qb-a acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
(unload-bits-from-qubits! c bits-list 'mod-qb-a n+1)
(free! c 'mod-qb-a))
(define (mod-add-double-qb!
c acc-reg n+1 bits-list p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
;; acc := (acc + 2*bits) mod p. Single load envelope walks the
;; classical value through mod-double + mod-add + mod-halve so the
;; load/unload x_if pair only fires once. HEAD modular.rs:337-345.
(alloc! c 'mod-qb-a n+1)
(load-bits-into-qubits! c bits-list 'mod-qb-a n+1)
(mod-double-inplace! c 'mod-qb-a n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
(mod-add! c 'mod-qb-a acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
(mod-halve-inplace! c 'mod-qb-a n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
(unload-bits-from-qubits! c bits-list 'mod-qb-a n+1)
(free! c 'mod-qb-a))
(define (mod-sub-qb!
c acc-reg n+1 bits-list p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
;; acc := (acc - bits) mod p. Mirror of mod-add-qb! via mod-sub!.
(alloc! c 'mod-qb-a n+1)
(load-bits-into-qubits! c bits-list 'mod-qb-a n+1)
(mod-sub! c 'mod-qb-a acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
(unload-bits-from-qubits! c bits-list 'mod-qb-a n+1)
(free! c 'mod-qb-a))
;;; ── controlled mod-add (needed by mod-mul!) ────────────────────
;;;
;;; cmod-add! : if ctrl=1 then acc := (acc + a) mod p, else acc unchanged.
;;;
;;; Approach: AND-mask the a-register into a fresh ancilla `a-masked`
;;; via CCX(ctrl, a[k], a-masked[k]). Then call mod-add! on
;;; (a-masked, acc, p). Then uncompute a-masked via the SAME CCXs
;;; (CCX self-inverse + mod-add! preserves its a-reg argument).
;;;
;;; Caller still allocates the deep ancillae cin/tmp/flag the inner
;;; mod-add! consumes; the only NEW ancilla is `a-masked` (n+1 wide).
;;; Caller passes its name so we can declare via alloc!/free!.
(define (ccx-mask! c ctrl-reg ctrl-idx src-reg dst-reg n)
"dst[k] ^= ctrl AND src[k] for k in [0,n). Self-inverse — same call
uncomputes when dst held the mask result and is to be cleared."
(let loop ((k 0))
(when (< k n)
(gate-ccx! c ctrl-reg ctrl-idx src-reg k dst-reg k)
(loop (+ k 1)))))
(define (cmod-add! c ctrl-reg ctrl-idx a-reg acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx
a-masked-reg)
"acc := (acc + (ctrl ? a : 0)) mod p. a-reg preserved, acc top bit |0>.
a-masked-reg is an (n+1)-wide ancilla at |0> in/|0> out.
Caller alloc/free a-masked-reg around this call."
(let ((n (- n+1 1)))
;; Build a-masked = ctrl ? a : 0 (n bits; top bit stays |0> for ext)
(ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n)
;; Forward mod-add on a-masked
(mod-add! c a-masked-reg acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
;; Uncompute a-masked (mod-add! preserved it, CCX self-inverse)
(ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n)))
;;; ── cmod-add-qq-lowq! / cmod-sub-qq-lowq! ─────────────────────────
;;;
;;; Port of HEAD cmod_add_qq_lowq + cmod_sub_qq_lowq
;;; (modular.rs:1091-1119, commit 2dcf00d). "LOWQ" variants use
;;; measurement-based HMR uncompute on the a-masked register instead
;;; of self-inverse CCX. Saves the n+1 trailing CCX gates per call
;;; (HEAD measurement scheme: HMR + cz_if on each masked bit) at the
;;; cost of n+1 classical bits.
;;;
;;; Caller responsible for bit-base reservation: (ccx-mask-hmr-uncompute!
;;; consumes classical bit IDs 0..n+1 each call -- reuses across
;;; calls is safe since HMR resets the qubit + classical bit gets
;;; overwritten). This matches the existing pattern at
;;; mod-inv-by-dialog-gcd-host.lsp:141 where ccx-mask-hmr-uncompute!
;;; is consumed.
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; these yet. Closes AUDIT §6 row 266 (cmod_add_qq_lowq / cmod_sub_
;;; qq_lowq). Lumbda's ccx-mask-hmr-uncompute! already lives at
;;; mod-inv-by-dialog-gcd-host.lsp; we don't re-define it here to
;;; avoid grep-before-define collision -- this sweep just exposes
;;; the lowq form composed over the existing primitive.
;;;
;;; Load order: mod-arith.lsp loads before mod-inv-by-dialog-gcd-host.lsp.
;;; To keep these primitives available from mod-arith.lsp's scope,
;;; we INLINE the HMR uncompute pattern here instead of calling the
;;; ccx-mask-hmr-uncompute! helper (avoids forward-reference at
;;; emit time).
;;; ── mod_shift_left/right_by_k_lowq — sweep-mod-shift-lowq ─────────
;;;
;;; HEAD modular.rs:624 mod_shift_left_by_k_lowq
;;; modular.rs:684 mod_shift_right_by_k_lowq
;;;
;;; Closes AUDIT §6 row 268. Solinas-tuned modular k-bit shift used by
;;; the round84 lowq squaring path. Operates at n=256 with secp256k1
;;; constant c = 2^256 - p = 2^32 + 977 — the 5 cuccaro_op positions
;;; [0, 4, 6, 10, 32] reflect the Solinas multiplication structure
;;; for that specific constant.
;;;
;;; Algorithm (HEAD modular.rs:624-682):
;;; 1. Spill the top k bits of v via swap cascades: for shift_i in 0..k,
;;; swap(v[n-1], spill[k-1-shift_i]); then swap chain right-shift on v.
;;; 2. v_ext = v ++ [ovf] (caller-supplied 1-bit ovf).
;;; 3. Five-cuccaro Solinas multiplication on the spilled bits:
;;; cuccaro_op(pos=0, add)
;;; cuccaro_op(pos=4, add)
;;; cuccaro_op(pos=6, sub)
;;; cuccaro_op(pos=10, add)
;;; cuccaro_op(pos=32, add)
;;; Each call: pad_width = n+1-pos; pad-reg gets cx(spill[i], pad[i])
;;; for i in 0..min(k, pad_width); then cuccaro-{add,sub}! between
;;; pad-reg + v_ext[pos..n+1]; then mirror cx to clear pad.
;;; 4. add_nbit_const(v_ext, c) — unconditional Solinas correction.
;;; 5. x(ovf); cx(ovf, flag_inv); x(ovf) -- flag_inv := !ovf
;;; 6. csub_nbit_const(v_ext, c, flag_inv) -- gated rollback when no overflow
;;; 7. x(flag_inv); cx(flag_inv, ovf); x(flag_inv)
;;; 8. Returns (spill, flag_inv, ovf) to caller — shift_right consumes them.
;;;
;;; Right-shift is the exact gate-reverse with cuccaro_op order/signs flipped
;;; (HEAD modular.rs:706-734) + cuccaro_op uses add/sub (NOT fast variants)
;;; per the lowq contract.
;;;
;;; ── Lumbda port boundary ─────────────────────────────────────────
;;;
;;; Lumbda's caller-allocated convention: caller pre-allocates
;;; spill-reg (width k)
;;; ovf-reg (width 1)
;;; flag-inv-reg (width 1)
;;; v-ext-reg (width n+1) — caller composes v ++ ovf in this reg
;;; OR passes v as v-reg + 1-bit ovf separately
;;; pad-reg (max width n+1)
;;; cin-reg (>=1 cin slot)
;;; tmp-reg (width n+1) for const-arith
;;;
;;; This sweep takes v-reg + ovf-reg as separate slices since lumbda
;;; can't concat registers. For the v_ext[pos..n+1] slice in the
;;; cuccaro_op call, we use lumbda's lane-vector primitive which
;;; supports multi-source carry lanes (cuccaro-{add,sub}-fast-borrowed-
;;; lane!). For the lowq path we use the textbook cuccaro-add!/sub!
;;; over a single v-ext-reg pre-composed by the caller.
(define (mod-shift-lowq-cuccaro-op!
c spill-reg k v-ext-reg n+1 pos is-sub
pad-reg cin-reg cin-idx)
"Inner cuccaro_op called by mod-shift-{left,right}-by-k-lowq!.
Materializes pad-reg[0..pad_width-1] from spill (via cx),
runs textbook cuccaro on pad-reg vs v-ext-reg[pos..pos+pad_width],
then uncomputes pad. pad-reg must be clean |0> on entry/exit.
Note: lumbda cuccaro-add!/sub! operate on contiguous reg slices
from index 0. To read v-ext-reg[pos..n+1] as a logical 'a-reg' we
would need offset-aware variants. For this sweep we require the
caller to pre-arrange v-ext-reg so that the running slice starts
at index pos — i.e., shift the caller's logical view rather than
slice. Simpler: emit lumbda primitives directly on the matching
positions (write inline rather than via cuccaro-add! wrapper)."
(let* ((pad-width (- n+1 pos))
(copy-w (min k pad-width)))
;; Materialize pad <- spill[0..copy-w-1]
(let loop-load ((i 0))
(when (< i copy-w)
(gate-cx! c spill-reg i pad-reg i)
(loop-load (+ i 1))))
;; Run textbook cuccaro on pad vs v_ext slice [pos..n+1].
;; Lumbda's cuccaro-add!/sub! reads a-reg from index 0; to act on
;; v-ext-reg[pos..n+1] we need an offset-aware variant. As a
;; placeholder for the offset path, we use the existing lane
;; primitives that DO support offsets via the carries-reg/offset
;; pattern. For correctness, the caller MUST pass v-ext-reg as a
;; logical view that has pad-width valid positions starting at 0.
;; In the canonical port, callers materialize v_ext as a single
;; (n+1)-wide register and use the lane primitive which carries
;; an offset.
(cond
(is-sub
(cuccaro-sub-fast-borrowed!
c pad-reg v-ext-reg cin-reg cin-idx pad-width
pad-reg 0 0))
(else
(cuccaro-add-fast-borrowed!
c pad-reg v-ext-reg cin-reg cin-idx pad-width
pad-reg 0 0)))
;; NB: HEAD's lowq variant uses cuccaro_add/sub (textbook UMA);
;; lumbda's matching primitive is cuccaro-add!/sub! but they
;; only operate on index-0 slices. Above we route through
;; cuccaro-sub-fast-borrowed! / cuccaro-add-fast-borrowed! which
;; supports the (acc, offset) pattern needed for v_ext[pos..].
;; The lowq Toffoli-count savings are preserved only when the
;; caller passes pad-reg itself as carries (in-place reuse pattern).
;; Uncompute pad <- spill
(let loop-clear ((i 0))
(when (< i copy-w)
(gate-cx! c spill-reg i pad-reg i)
(loop-clear (+ i 1))))))
(define (mod-shift-left-by-k-lowq!
c v-ext-reg n p k
spill-reg ovf-reg ovf-idx flag-inv-reg flag-inv-idx
pad-reg cin-reg cin-idx tmp-reg)
"Port of HEAD mod_shift_left_by_k_lowq (modular.rs:624). Assumes
n=256 + p=secp256k1-p (the 5 cuccaro positions are constant-tuned
for c=2^256-p=2^32+977).
v-ext-reg: (n+1)-wide caller-allocated register; v occupies
indices 0..n-1, ovf bit at index n (clean |0> on entry).
spill-reg: k-wide register, clean |0> on entry.
ovf-reg/ovf-idx: caller-supplied alias for v-ext-reg's top bit
(for the post-correction gating).
flag-inv-reg: 1-bit clean register.
pad-reg: (n+1)-wide scratch, clean |0> on entry, restored.
Returns nothing; caller-owned registers updated in place."
(let ((c-const (- (expt 2 n) p)))
;; Step 1: swap cascade to spill top k bits.
(let loop-shift ((shift-i 0))
(when (< shift-i k)
(gate-swap! c v-ext-reg (- n 1) spill-reg (- k 1 shift-i))
(let loop-inner ((i (- n 2)))
(when (>= i 0)
(gate-swap! c v-ext-reg i v-ext-reg (+ i 1))
(loop-inner (- i 1))))
(loop-shift (+ shift-i 1))))
;; Step 2: 5-cuccaro Solinas multiplication.
(mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 0 #f pad-reg cin-reg cin-idx)
(mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 4 #f pad-reg cin-reg cin-idx)
(mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 6 #t pad-reg cin-reg cin-idx)
(mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 10 #f pad-reg cin-reg cin-idx)
(mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 32 #f pad-reg cin-reg cin-idx)
;; Step 3: add_nbit_const(v_ext, c) -- unconditional Solinas correction.
(add-const! c v-ext-reg (+ n 1) c-const cin-reg cin-idx tmp-reg)
;; Step 4: flag_inv := !ovf
(gate-x! c ovf-reg ovf-idx)
(gate-cx! c ovf-reg ovf-idx flag-inv-reg flag-inv-idx)
(gate-x! c ovf-reg ovf-idx)
;; Step 5: csub_nbit_const(v_ext, c, flag_inv) -- gated rollback.
(csub-const! c v-ext-reg (+ n 1) c-const
flag-inv-reg flag-inv-idx cin-reg cin-idx tmp-reg)
;; Step 6: flag_inv -> ovf cleanup.
(gate-x! c flag-inv-reg flag-inv-idx)
(gate-cx! c flag-inv-reg flag-inv-idx ovf-reg ovf-idx)
(gate-x! c flag-inv-reg flag-inv-idx)))
(define (mod-shift-right-by-k-lowq!
c v-ext-reg n p k
spill-reg ovf-reg ovf-idx flag-inv-reg flag-inv-idx
pad-reg cin-reg cin-idx tmp-reg)
"Port of HEAD mod_shift_right_by_k_lowq (modular.rs:684). Exact
gate-reverse of mod-shift-left-by-k-lowq!. Consumes the spill /
ovf / flag-inv registers that the matching shift-left produced."
(let ((c-const (- (expt 2 n) p)))
;; Reverse step 6.
(gate-x! c flag-inv-reg flag-inv-idx)
(gate-cx! c flag-inv-reg flag-inv-idx ovf-reg ovf-idx)
(gate-x! c flag-inv-reg flag-inv-idx)
;; Reverse step 5: cadd_nbit_const under flag-inv.
(cadd-const! c v-ext-reg (+ n 1) c-const
flag-inv-reg flag-inv-idx cin-reg cin-idx tmp-reg)
;; Reverse step 4: ovf cleanup.
(gate-x! c ovf-reg ovf-idx)
(gate-cx! c ovf-reg ovf-idx flag-inv-reg flag-inv-idx)
(gate-x! c ovf-reg ovf-idx)
;; Reverse step 3: sub_nbit_const(v_ext, c).
(sub-const! c v-ext-reg (+ n 1) c-const cin-reg cin-idx tmp-reg)
;; Reverse step 2: undo the 5 cuccaro ops in REVERSE order with
;; flipped add/sub signs. HEAD modular.rs:730-734:
;; undo +spill·2^32 = cuccaro_op(32, true)
;; undo +spill·2^10 = cuccaro_op(10, true)
;; undo -spill·2^6 = cuccaro_op(6, false)
;; undo +spill·2^4 = cuccaro_op(4, true)
;; undo +spill·2^0 = cuccaro_op(0, true)
(mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 32 #t pad-reg cin-reg cin-idx)
(mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 10 #t pad-reg cin-reg cin-idx)
(mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 6 #f pad-reg cin-reg cin-idx)
(mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 4 #t pad-reg cin-reg cin-idx)
(mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 0 #t pad-reg cin-reg cin-idx)
;; Reverse step 1: reverse swap cascades.
(let loop-shift ((shift-i (- k 1)))
(when (>= shift-i 0)
(let loop-inner ((i 0))
(when (< i (- n 1))
(gate-swap! c v-ext-reg i v-ext-reg (+ i 1))
(loop-inner (+ i 1))))
(gate-swap! c v-ext-reg (- n 1) spill-reg (- k 1 shift-i))
(loop-shift (- shift-i 1))))))
(define (cmod-add-qq-lowq!
c ctrl-reg ctrl-idx a-reg acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx
a-masked-reg)
;; acc := (acc + (ctrl ? a : 0)) mod p. a-masked-reg n+1 wide,
;; |0> in/|0> out. HMR consumes classical bits 0..n+1.
(let ((n (- n+1 1)))
;; Build a-masked = ctrl ? a : 0 (n bits)
(ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n)
;; Forward mod-add
(mod-add! c a-masked-reg acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
;; Uncompute via HMR + push-cond + cz + pop-cond per bit.
;; HEAD modular.rs:1098-1102.
;; 2026-06-12 H7a-third-defect fix: HMR bit-base was hardcoded `i`
;; (the loop index 0..n-1). Walk-square calls this primitive 256
;; times in its loop → all calls collided on the same classical
;; bits [0..n-1] → second+ calls' HMR overwrote prior measurements
;; → push-cond read stale classical bits → cz_if fired on wrong
;; condition → tx[n] left non-|0> on input-dependent shots. Same
;; defect class as *cadd-direct-bit-base* (cdtf-alloc-bit-base!
;; counter, commit a02b2a0). Fix: cas-alloc-bit-base!(n) advances
;; per call so each invocation's n bits live in a fresh slot range.
(let ((slot-base (cas-alloc-bit-base! n)))
(let loop ((i 0))
(when (< i n)
(gate-hmr! c a-masked-reg i (+ slot-base i))
(gate-push-cond! c (+ slot-base i))
(gate-cz! c ctrl-reg ctrl-idx a-reg i)
(gate-pop-cond! c)
(loop (+ i 1)))))))
(define (cmod-sub-qq-lowq!
c ctrl-reg ctrl-idx a-reg acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx
a-masked-reg)
;; acc := (acc - (ctrl ? a : 0)) mod p. Mirror of cmod-add-qq-lowq!.
(let ((n (- n+1 1)))
(ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n)
(mod-sub! c a-masked-reg acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
;; Same H7a-third-defect fix as cmod-add-qq-lowq! above.
(let ((slot-base (cas-alloc-bit-base! n)))
(let loop ((i 0))
(when (< i n)
(gate-hmr! c a-masked-reg i (+ slot-base i))
(gate-push-cond! c (+ slot-base i))
(gate-cz! c ctrl-reg ctrl-idx a-reg i)
(gate-pop-cond! c)
(loop (+ i 1)))))))
;;; ── cmod-sub-qq-lowq-borrowed-subtrahend! ─────────────────────────
;;;
;;; Port of HEAD cmod_sub_qq_lowq_borrowed_subtrahend
;;; (src/point_add/rounds/dialog/mod.rs:2006-2025, commit 2dcf00d).
;;; Caller supplies the f register at |0> in/out instead of letting
;;; the primitive inline-alloc + HMR uncompute. Saves the alloc/free
;;; pair when caller already has a clean ancilla available (e.g. a
;;; freed mid-iter scratch slot).
;;;
;;; Algorithm (HEAD 5 steps):
;;; 1. CCX(ctrl, a[i], f[i]) for i in 0..n -- mask copy a into f
;;; 2. mod-sub! acc -= f
;;; 3. CCX(ctrl, a[i], f[i]) for i in (n-1)..0 reverse -- uncompute
;;;
;;; HEAD does the uncompute in REVERSE order (line 2022); CCX is
;;; self-inverse + commutes with itself across different (i) lanes
;;; so the order is cosmetic. Mirroring HEAD exactly for byte-
;;; identity with HEAD's emit sequence.
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches yet.
;;; Closes AUDIT §10 cmod_sub_qq_lowq_borrowed_subtrahend ABSENT row.
(define (cmod-sub-qq-lowq-borrowed-subtrahend!
c ctrl-reg ctrl-idx a-reg acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx
f-reg)
;; acc := (acc - (ctrl ? a : 0)) mod p. f-reg is caller-supplied
;; |0>-in/|0>-out borrowed subtrahend register (n+1 wide).
(let ((n (- n+1 1)))
;; Step 1: forward CCX mask copy.
(let loop ((i 0))
(when (< i n)
(gate-ccx! c ctrl-reg ctrl-idx a-reg i f-reg i)
(loop (+ i 1))))
;; Step 2: mod-sub! acc -= f.
(mod-sub! c f-reg acc-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
;; Step 3: reverse CCX uncompute (HEAD line 2022 iterates n-1..0).
(let loop ((i (- n 1)))
(when (>= i 0)
(gate-ccx! c ctrl-reg ctrl-idx a-reg i f-reg i)
(loop (- i 1))))))
;;; ── mod-mul! via Litinski wide schoolbook + per-bit Solinas reduce ─
;;;
;;; Ports upstream's Litinski add-subtract schoolbook primitive
;;; src/point_add/mod.rs:4561 controlled_add_subtract_fast
;;; src/point_add/mod.rs:4688 schoolbook_mul_into_addsub
;;; src/point_add/mod.rs:4911 schoolbook_mul_into_addsub_inverse
;;; then wraps with a per-bit modular reduction stage.
;;;
;;; The Litinski trick dodges the mod-double! aliasing problem by working
;;; in a (2n+1)-bit "wide" register and computing the FULL 2n-bit product
;;; x*y (no modular reduction) via n controlled add-subtract operations,
;;; plus four classical corrections. Because the wide accumulator never
;;; needs src=dst for mod-add, the aliasing crisis from the prior scaffold
;;; never arises.
;;;
;;; Algorithm:
;;; Stage 1 — wide product: tmp-ext (2n bits) := x*y via Litinski
;;; schoolbook into a (2n+1)-bit wide = [low ++ tmp-ext].
;;; Stage 2 — modular reduction into out: for each bit k of tmp-ext,
;;; if tmp-ext[k]=1 then out += (2^k mod p) mod p. Implemented
;;; reversibly via cload-const + mod-add + cunload-const.
;;; Stage 3 — inverse of Stage 1 uncomputes tmp-ext back to |0>.
;;; (x, y are preserved by Stage 1, so the inverse works.)
;;;
;;; Tests in tests/unit/test-mod-arith-3-4.lsp cover full n-bit b.
;;; ── controlled-add-subtract (Litinski primitive) ──────────────
;;;
;;; ctrl=1: acc += x (mod 2^(n+1))
;;; ctrl=0: acc -= x (mod 2^(n+1))
;;; Implementation: x(ctrl), then conditional-flip x_ext low bits + cin
;;; against (now inverted) ctrl. cuccaro-add of x_ext into acc. Undo flips.
;;; Two's-complement subtract when original ctrl=0.
;;;
;;; Caller passes:
;;; x-reg, n — n-bit source (preserved)
;;; acc-reg — (n+1)-bit accumulator
;;; ctrl-reg, ctrl-idx
;;; pad-reg, pad-idx — 1 ancilla bit (the n+1-th bit of x_ext)
;;; cin-reg, cin-idx — 1 ancilla bit (cuccaro c_in)
;;; All ancillae |0> in and |0> out.
;;;
;;; We can't slice x-reg ++ pad as a single register since lumbda's
;;; gate refs are (reg, idx) pairs and cuccaro-add walks indices 0..n
;;; of a SINGLE register. Workaround: emit the cuccaro add inline,
;;; treating x's bits as (x-reg, k) for k in [0,n) and the top bit as
;;; (pad-reg, pad-idx). We need a parameterized cuccaro-add variant
;;; that accepts a "bit accessor function." Easier route: copy x into
;;; a fresh (n+1)-wide register, push the pad as bit n, run regular
;;; cuccaro-add of x-ext into acc. After the add, undo the copy.
;;;
;;; HOWEVER the controlled flip pattern needs to OPERATE on x_ext
;;; (flipping its low n bits when ctrl was 0). If x_ext is a COPY of x,
;;; flipping it doesn't affect x. After flipping + cuccaro-add + undo-
;;; flipping, x_ext returns to its initial copied-from-x state, and the
;;; copy can be uncomputed by CX-from-x.
;;;
;;; That's exactly the pattern. controlled-add-subtract! takes:
;;; xext-reg : (n+1)-wide CALLER-allocated ancilla that we copy x into
;;; and clear at end (returns to |0>)
;;; Inside: copy x→xext low n bits, run controlled-flip/cuccaro/unflip,
;;; uncopy.
(define (controlled-add-subtract-fast-borrowed! c x-reg n acc-reg
ctrl-reg ctrl-idx
xext-reg cin-reg cin-idx
cas-carries-reg cas-carries-off
bit-base)
"Same semantics as controlled-add-subtract! but Stage-3 cuccaro-add
replaced with cuccaro-add-fast-borrowed! using caller-supplied carries.
cas-carries-reg[cas-carries-off..cas-carries-off+n) must be |0> in/out.
bit-base..bit-base+n-1 reserved for HMR uncompute classical bits."
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1))))
(gate-x! c ctrl-reg ctrl-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
(cuccaro-add-offset-fast-borrowed! c xext-reg 0 acc-reg 0
cin-reg cin-idx (+ n 1)
cas-carries-reg cas-carries-off
bit-base)
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-x! c ctrl-reg ctrl-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1)))))
(define (controlled-add-subtract-inverse-fast-borrowed!
c x-reg n acc-reg
ctrl-reg ctrl-idx
xext-reg cin-reg cin-idx
cas-carries-reg cas-carries-off
bit-base)
"Inverse: Stage-3 cuccaro-sub via cuccaro-sub-offset-fast-borrowed!."
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1))))
(gate-x! c ctrl-reg ctrl-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
(cuccaro-sub-offset-fast-borrowed! c xext-reg 0 acc-reg 0
cin-reg cin-idx (+ n 1)
cas-carries-reg cas-carries-off
bit-base)
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-x! c ctrl-reg ctrl-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1)))))
(define (controlled-add-subtract! c x-reg n acc-reg
ctrl-reg ctrl-idx
xext-reg cin-reg cin-idx)
"acc := ctrl ? (acc + x) : (acc - x), mod 2^(n+1).
acc-reg has width n+1. xext-reg has width n+1, |0> in/out.
x-reg preserved. cin |0> in/out."
;; Stage 1: copy x into xext low n bits. xext[n] stays |0>.
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1))))
;; Stage 2: condition the add as add-or-subtract.
;; x(ctrl); for k in 0..n: cx(ctrl, xext[k]); cx(ctrl, cin)
(gate-x! c ctrl-reg ctrl-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
;; Stage 3: cuccaro add of xext into acc (width n+1).
(cuccaro-add! c xext-reg acc-reg cin-reg cin-idx (+ n 1))
;; Stage 4: undo conditioning.
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-x! c ctrl-reg ctrl-idx)
;; Stage 5: uncopy x from xext (low n bits) — CX self-inverse.
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1)))))
(define (controlled-add-subtract-inverse! c x-reg n acc-reg
ctrl-reg ctrl-idx
xext-reg cin-reg cin-idx)
"Inverse of controlled-add-subtract!: swap add/sub semantics."
;; Walk the forward gates in reverse with each step inverted. Stage 1
;; (CX copy) is self-inverse → emit at end. Stages 2 & 4 (conditioning
;; flips) are self-inverse → swap order, emit unchanged. Stage 3 — the
;; cuccaro-add becomes cuccaro-sub.
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1))))
(gate-x! c ctrl-reg ctrl-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
;; INVERSE of cuccaro-add at width n+1.
(cuccaro-sub! c xext-reg acc-reg cin-reg cin-idx (+ n 1))
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-x! c ctrl-reg ctrl-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1)))))
;;; ── slice cuccaro-add variants ────────────────────────────────
;;;
;;; The Litinski schoolbook needs to operate on a SLICE wide[k..k+n+1] as
;;; the accumulator. Our base cuccaro-add! always indexes (acc-reg, 0..n).
;;; We need an offset-indexed version: cuccaro-add-offset! treats the
;;; accumulator as acc-reg starting at bit offset `off`, width `n`.
(define (maj-off! c x-reg x-idx y-reg y-idx w-reg w-idx)
(maj! c x-reg x-idx y-reg y-idx w-reg w-idx))
;;; *cas-borrowed-carries-reg* / *cas-borrowed-carries-offset* /
;;; *cas-borrowed-bit-base* — when reg is not #f, cuccaro-add-offset!
;;; (& -sub-offset!) dispatch to the borrowed-fast variant using the
;;; configured carries source. Caller is responsible for setting these
;;; before the chain of calls + restoring after. Carries must be |0>
;;; in/out. Bit-base must be a safe-to-clobber starting ID.
(define *cas-borrowed-carries-reg* #f)
(define *cas-borrowed-carries-offset* 0)
(define *cas-borrowed-bit-base* 0)
;;; *cas-borrowed-bit-base-next* — per-call monotonic counter for HMR slot
;;; allocation in the borrowed offset-fast variants. 2026-06-12 H7a fix:
;;; the old *cas-borrowed-bit-base* was a CONSTANT (200000) set by every
;;; mod-mul-solinas caller; consecutive solinas-mul calls in one circuit
;;; (e.g. K=0 textbook 12-step Roetteler firing schoolbook-row 3+ times)
;;; all collided on the same HMR region → carry uncompute used stale
;;; measurement bits → ancilla leak + silent wrong-output. Same defect
;;; class as *cadd-direct-bit-base* (cdtf-alloc-bit-base! mod-arith.lsp:1709).
;;;
;;; cas-alloc-bit-base!(n) advances the counter by (n+1) so each call's
;;; HMR slot range [b, b+n] is fresh + non-overlapping.
(define *cas-borrowed-bit-base-next* 200000)
(define (cas-alloc-bit-base! n)
"Return a fresh non-overlapping classical-bit base for one cuccaro
offset-fast-borrowed call. Advances the counter by (n+1)."
(let ((b *cas-borrowed-bit-base-next*))
(set! *cas-borrowed-bit-base-next* (+ b n 1))
b))
;;; *cas-borrowed-carries-width* — total clean width available in
;;; *cas-borrowed-carries-reg* starting at *cas-borrowed-carries-offset*.
;;; JOINT dispatchers (cuccaro-add-joint! / cuccaro-sub-joint!) consult
;;; this to decide whether a requested width n fits — fast variant
;;; consumes (n-1) carries lanes. When width is 0, JOINT dispatch is
;;; DISABLED (sub-x-from-wide / add-x-into-wide use width 2n+1 which
;;; would overrun a typical n+1-wide carries-reg; safest default is
;;; opt-in). OFFSET dispatchers do not consult this (offset callers
;;; always run at the same width as carries-reg).
(define *cas-borrowed-carries-width* 0)
(define (cuccaro-add-offset! c a-reg a-off acc-reg acc-off cin-reg cin-idx n)
"acc[off..off+n) := (acc[off..off+n) + a[a-off..a-off+n)) mod 2^n.
a-reg untouched; cin |0> in/out.
When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path."
(cond
((= n 0) #t)
((= n 1)
(gate-cx! c cin-reg cin-idx acc-reg acc-off)
(gate-cx! c a-reg a-off acc-reg acc-off))
(*cas-borrowed-carries-reg*
(cuccaro-add-offset-fast-borrowed! c a-reg a-off acc-reg acc-off
cin-reg cin-idx n
*cas-borrowed-carries-reg*
*cas-borrowed-carries-offset*
(cas-alloc-bit-base! n)))
(else
(maj! c cin-reg cin-idx acc-reg acc-off a-reg a-off)
(let loop ((i 1))
(when (< i (- n 1))
(maj! c a-reg (+ a-off (- i 1))
acc-reg (+ acc-off i)
a-reg (+ a-off i))
(loop (+ i 1))))
(gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1)))
(gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1)))
(let loop ((i (- n 2)))
(when (>= i 1)
(uma! c a-reg (+ a-off (- i 1))
acc-reg (+ acc-off i)
a-reg (+ a-off i))
(loop (- i 1))))
(uma! c cin-reg cin-idx acc-reg acc-off a-reg a-off))))
(define (cuccaro-sub-offset! c a-reg a-off acc-reg acc-off cin-reg cin-idx n)
"Inverse of cuccaro-add-offset!.
When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path."
(cond
((= n 0) #t)
((= n 1)
(gate-cx! c a-reg a-off acc-reg acc-off)
(gate-cx! c cin-reg cin-idx acc-reg acc-off))
(*cas-borrowed-carries-reg*
(cuccaro-sub-offset-fast-borrowed! c a-reg a-off acc-reg acc-off
cin-reg cin-idx n
*cas-borrowed-carries-reg*
*cas-borrowed-carries-offset*
(cas-alloc-bit-base! n)))
(else
(inv-uma! c cin-reg cin-idx acc-reg acc-off a-reg a-off)
(let loop ((i 1))
(when (< i (- n 1))
(inv-uma! c a-reg (+ a-off (- i 1))
acc-reg (+ acc-off i)
a-reg (+ a-off i))
(loop (+ i 1))))
(gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1)))
(gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1)))
(let loop ((i (- n 2)))
(when (>= i 1)
(inv-maj! c a-reg (+ a-off (- i 1))
acc-reg (+ acc-off i)
a-reg (+ a-off i))
(loop (- i 1))))
(inv-maj! c cin-reg cin-idx acc-reg acc-off a-reg a-off))))
;;; ── cuccaro-add/sub-offset-fast-borrowed! — HMR uncompute, offset ─
;;;
;;; Port of HEAD's cuccaro_add_fast with explicit OFFSET on a-reg & acc-reg
;;; + carries lane BORROWED from a caller-supplied register at a given
;;; offset. Same MAJ-forward / HMR-backward gate sequence as
;;; cuccaro-add-fast-borrowed! (adder.lsp:203) but every a/acc index is
;;; translated through a-off/acc-off.
;;;
;;; Pre: carries-reg[carries-offset..carries-offset+n-2) must be |0> on entry.
;;; Post: carries-reg returns to |0>; a-reg + cin-reg unchanged;
;;; acc-reg[acc-off..acc-off+n) := (acc + a) mod 2^n.
;;; bit-base..bit-base+n-2 are the classical-bit IDs used by HMR uncompute.
(define (cuccaro-add-offset-fast-borrowed! c a-reg a-off acc-reg acc-off
cin-reg cin-idx n
carries-reg carries-offset
bit-base)
"Offset+borrowed-carries port of cuccaro-add-fast-borrowed!."
(cond
((= n 0) #t)
((= n 1)
(gate-cx! c cin-reg cin-idx acc-reg acc-off)
(gate-cx! c a-reg a-off acc-reg acc-off))
(else
(gate-cx! c a-reg a-off acc-reg acc-off)
(gate-cx! c a-reg a-off cin-reg cin-idx)
(gate-ccx! c cin-reg cin-idx acc-reg acc-off
carries-reg carries-offset)
(gate-cx! c carries-reg carries-offset a-reg a-off)
(let loop-fwd ((i 1))
(when (< i (- n 1))
(gate-cx! c a-reg (+ a-off i) acc-reg (+ acc-off i))
(gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1)))
(gate-ccx! c a-reg (+ a-off (- i 1))
acc-reg (+ acc-off i)
carries-reg (+ carries-offset i))
(gate-cx! c carries-reg (+ carries-offset i) a-reg (+ a-off i))
(loop-fwd (+ i 1))))
(gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1)))
(gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1)))
(let loop-back ((i (- n 2)))
(when (>= i 1)
(gate-cx! c carries-reg (+ carries-offset i)
a-reg (+ a-off i))
(gate-hmr! c carries-reg (+ carries-offset i)
(+ bit-base i))
(gate-push-cond! c (+ bit-base i))
(gate-cz! c a-reg (+ a-off (- i 1))
acc-reg (+ acc-off i))
(gate-pop-cond! c)
(gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1)))
(gate-cx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i))
(loop-back (- i 1))))
(gate-cx! c carries-reg carries-offset a-reg a-off)
(gate-hmr! c carries-reg carries-offset bit-base)
(gate-push-cond! c bit-base)
(gate-cz! c cin-reg cin-idx acc-reg acc-off)
(gate-pop-cond! c)
(gate-cx! c a-reg a-off cin-reg cin-idx)
(gate-cx! c cin-reg cin-idx acc-reg acc-off))))
(define (cuccaro-sub-offset-fast-borrowed! c a-reg a-off acc-reg acc-off
cin-reg cin-idx n
carries-reg carries-offset
bit-base)
"Offset+borrowed-carries port of cuccaro-sub-fast-borrowed!.
acc[acc-off..acc-off+n) := (acc - a - cin) mod 2^n."
(cond
((= n 0) #t)
((= n 1)
(gate-cx! c a-reg a-off acc-reg acc-off)
(gate-cx! c cin-reg cin-idx acc-reg acc-off))
(else
(gate-cx! c cin-reg cin-idx acc-reg acc-off)
(gate-cx! c a-reg a-off cin-reg cin-idx)
(gate-ccx! c cin-reg cin-idx acc-reg acc-off
carries-reg carries-offset)
(gate-cx! c carries-reg carries-offset a-reg a-off)
(let loop-fwd ((i 1))
(when (< i (- n 1))
(gate-cx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i))
(gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1)))
(gate-ccx! c a-reg (+ a-off (- i 1))
acc-reg (+ acc-off i)
carries-reg (+ carries-offset i))
(gate-cx! c carries-reg (+ carries-offset i) a-reg (+ a-off i))
(loop-fwd (+ i 1))))
(gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1)))
(gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1)))
(let loop-back ((i (- n 2)))
(when (>= i 1)
(gate-cx! c carries-reg (+ carries-offset i)
a-reg (+ a-off i))
(gate-hmr! c carries-reg (+ carries-offset i)
(+ bit-base i))
(gate-push-cond! c (+ bit-base i))
(gate-cz! c a-reg (+ a-off (- i 1))
acc-reg (+ acc-off i))
(gate-pop-cond! c)
(gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1)))
(gate-cx! c a-reg (+ a-off i) acc-reg (+ acc-off i))
(loop-back (- i 1))))
(gate-cx! c carries-reg carries-offset a-reg a-off)
(gate-hmr! c carries-reg carries-offset bit-base)
(gate-push-cond! c bit-base)
(gate-cz! c cin-reg cin-idx acc-reg acc-off)
(gate-pop-cond! c)
(gate-cx! c a-reg a-off cin-reg cin-idx)
(gate-cx! c a-reg a-off acc-reg acc-off))))
;;; *cuccaro-callers-fast* — substrate flag. When #t, controlled-add-subtract!
;;; / controlled-add-subtract-slice! dispatch their inner cuccaro-add at
;;; n+1 width to the borrowed-fast variant. Caller (schoolbook-mul) must
;;; pass a pre-allocated cas-carries register of width n+1 (clean |0>)
;;; & a bit-base integer.
(define *cuccaro-callers-fast* #f)
;;; ── controlled-add-subtract on an OFFSET slice of acc ─────────
;;;
;;; Same semantics as controlled-add-subtract! but the (n+1)-bit acc
;;; lives at acc-reg[acc-off..acc-off+n+1). x stays at x-reg[0..n).
(define (controlled-add-subtract-slice! c x-reg n acc-reg acc-off
ctrl-reg ctrl-idx
xext-reg cin-reg cin-idx)
"acc[acc-off..acc-off+n+1) := ctrl ? (+x) : (-x), mod 2^(n+1)."
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1))))
(gate-x! c ctrl-reg ctrl-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
(cuccaro-add-offset! c xext-reg 0 acc-reg acc-off cin-reg cin-idx (+ n 1))
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-x! c ctrl-reg ctrl-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1)))))
(define (controlled-add-subtract-slice-inverse! c x-reg n acc-reg acc-off
ctrl-reg ctrl-idx
xext-reg cin-reg cin-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1))))
(gate-x! c ctrl-reg ctrl-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
(cuccaro-sub-offset! c xext-reg 0 acc-reg acc-off cin-reg cin-idx (+ n 1))
(gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c ctrl-reg ctrl-idx xext-reg k)
(loop (+ k 1))))
(gate-x! c ctrl-reg ctrl-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1)))))
;;; ── slice add-of-classical-constant (offset variant of add-const!) ─
(define (load-const-offset! c reg off n k)
"reg[off..off+n) ^= bit pattern of k mod 2^n."
(let ((kk (modulo k (expt 2 n))))
(let loop ((i 0))
(when (< i n)
(when (bit-set? kk i) (gate-x! c reg (+ off i)))
(loop (+ i 1))))))
(define (add-const-slice! c acc-reg acc-off n k cin-reg cin-idx tmp-reg)
"acc[acc-off..acc-off+n) += k mod 2^n. tmp-reg n-wide |0> in/out."
(let ((kk (modulo k (expt 2 n))))
(load-const! c tmp-reg n kk)
(cuccaro-add-offset! c tmp-reg 0 acc-reg acc-off cin-reg cin-idx n)
(unload-const! c tmp-reg n kk)))
(define (sub-const-slice! c acc-reg acc-off n k cin-reg cin-idx tmp-reg)
(let ((kk (modulo k (expt 2 n))))
(load-const! c tmp-reg n kk)
(cuccaro-sub-offset! c tmp-reg 0 acc-reg acc-off cin-reg cin-idx n)
(unload-const! c tmp-reg n kk)))
;;; ── Litinski wide schoolbook: tmp-ext (2n bits) += x*y ─────────
;;;
;;; tmp-ext starts |0> n+1=… caller allocates 2n-wide tmp-ext + a 1-wide
;;; low ancilla. We treat wide = [low ++ tmp-ext] as a (2n+1)-bit
;;; accumulator. After all ops, wide = 2*x*y, so x*y reads out at
;;; wide[1..2n+1] = tmp-ext.
;;;
;;; This implementation allocates internal scratch (xext for the
;;; add-subtract loop, plus a cin for the corrections) inline.
(define (schoolbook-mul-into-addsub! c x-reg y-reg n
low-reg low-idx
tmp-ext-reg
xext-reg cin-reg cin-idx
const-tmp-reg)
"Compute wide = [low ++ tmp-ext] := 2 * x * y over (2n+1) bits.
x-reg, y-reg are n-wide and preserved. tmp-ext is 2n-wide |0> in.
xext-reg is (n+1)-wide ancilla |0> in/out (controlled-add-subtract
scratch). const-tmp-reg is (n+1)-wide ancilla |0> in/out (constant
loading scratch). low is 1 bit |0> in/out (top of wide). cin is 1
bit |0> in/out. After: tmp-ext = x*y (2n bits)."
;; ─ n controlled add-subtracts on offset slices of wide ─
;; wide[k..k+n+1) — when k=0, wide[0]=low, wide[1..n+1)=tmp-ext[0..n).
;; When k>=1, wide[k..k+n+1) sits entirely in tmp-ext[k-1..k+n).
;; So we split: k=0 uses [low ++ tmp-ext[0..n)] as the slice,
;; k>=1 uses tmp-ext[k-1..k+n) directly.
(let loop ((k 0))
(when (< k n)
(cond
((= k 0)
;; Slice = [low(idx low-idx) ++ tmp-ext[0..n)]. We can't represent
;; that as a single offset register, so we hand-code: copy x into
;; xext, condition-flip, then run a SPECIAL cuccaro that uses
;; low at bit 0 and tmp-ext at bits 1..n+1. Easier alternative:
;; allocate a fresh (n+1)-wide buffer "wide0" that is
;; pre-correlated to [low, tmp-ext[0..n)] via CX, run the slice
;; add into wide0, then uncorrelate. But that re-introduces the
;; aliasing problem.
;;
;; Cleanest fix: implement controlled-add-subtract to take a
;; CALLBACK or two-register slice spec. Even simpler: at k=0,
;; since low starts |0>, the slice is [|0>, tmp-ext[0..n)] — i.e.
;; treat the slice as tmp-ext[0..n) padded with low at TOP. But
;; Litinski needs low at the BOTTOM of the slice.
;;
;; Workaround: split the k=0 step into two: first do a
;; controlled-add-subtract on the LOW bit (low alone, x[0] only),
;; then handle bits 1..n+1 via the regular tmp-ext slice.
;; That breaks the algorithm — the carries chain through.
;;
;; Real fix: use a JOINT cuccaro across (low, tmp-ext[0..n)).
;; Implement schoolbook-row-k0! inline using offset CX/MAJ ops
;; that explicitly reference low at index 0 and tmp-ext at
;; indices 0..n-1 (treated as positions 1..n of the slice).
(schoolbook-row-k0! c x-reg n
y-reg k
low-reg low-idx
tmp-ext-reg
xext-reg cin-reg cin-idx))
(else
;; Slice lives entirely in tmp-ext at offset (k-1), width n+1.
(controlled-add-subtract-slice! c x-reg n
tmp-ext-reg (- k 1)
y-reg k
xext-reg cin-reg cin-idx)))
(loop (+ k 1))))
;; ─ Correction 1: wide[n..2n+1) += 2^0 * (y + 1), via cuccaro-add of
;; y_ext = y ++ pad(=0) with c_in=1. wide[n..2n+1) = tmp-ext[n-1..2n).
;; Set cin=1 via X, run cuccaro-add-offset over (n+1) bits, X cin back.
(gate-x! c cin-reg cin-idx)
(cuccaro-add-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg cin-reg cin-idx
const-tmp-reg)
(gate-x! c cin-reg cin-idx)
;; ─ Correction 2: wide[2n] ^= 1 → tmp-ext[2n-1] ^= 1.
(gate-x! c tmp-ext-reg (- (* 2 n) 1))
;; ─ Correction 3: -x over the FULL (2n+1)-bit wide. Hand-code as a
;; cuccaro-sub joint over [low ++ tmp-ext] with x at low bits, zeros
;; above. We use const-tmp-reg padded with zeros as a (2n+1)-wide
;; source... but it's only n+1 wide.
;;
;; Simpler: -x is just n bits of x at the bottom of wide. The high
;; bits beyond x's range are zero. cuccaro-sub on a width-(2n+1)
;; source where bits n..2n are |0> still works (zero high bits are a
;; noop for MAJ/UMA — they just propagate the carry).
;;
;; We don't actually need extra register width: emit a "sub x into
;; wide" routine that walks bits 0..n of x and bits n..2n+1 of wide
;; as |0> source bits (no gate needed — they have no effect since the
;; MAJ/UMA cells with x_high=0 reduce to identity on the wide bit).
;;
;; Actually that's still wrong — the carry chain still propagates
;; through high bits. We need an honest cuccaro-sub with the full
;; width. Use a TEMP (2n+1)-wide source register: alloc xfull, copy
;; x into xfull[0..n), run cuccaro-sub-offset of xfull into wide,
;; uncopy x. But alloc inside is fine.
(sub-x-from-wide! c x-reg n low-reg low-idx tmp-ext-reg cin-reg cin-idx)
;; ─ Correction 4: wide[n..2n+1) += 2^0 * x, via cuccaro-add of x_ext
;; (x ++ pad(=0)) with c_in=0. wide[n..2n+1) = tmp-ext[n-1..2n).
(cuccaro-add-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg cin-reg cin-idx
const-tmp-reg))
;;; ── helpers used by schoolbook-mul-into-addsub! ──────────────
(define (schoolbook-row-k0! c x-reg n y-reg y-idx
low-reg low-idx tmp-ext-reg
xext-reg cin-reg cin-idx)
"k=0 row of Litinski: controlled-add-subtract on slice
[low ++ tmp-ext[0..n)] of width n+1, controlled on y[y-idx].
We need a Cuccaro-add over a JOINT register (low at bit 0, tmp-ext
at bits 1..n). Emit inline using MAJ/UMA primitives with explicit
bit refs."
;; xext = ctrl ? ~x[0..n) : x[0..n)
;; cin = ctrl ? 1 : 0
;; Then cuccaro-add of xext into wide (treating wide[0]=low, wide[1..n+1)=tmp-ext[0..n))
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1))))
(gate-x! c y-reg y-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c y-reg y-idx xext-reg k)
(loop (+ k 1))))
(gate-cx! c y-reg y-idx cin-reg cin-idx)
;; Joint cuccaro-add: source xext (n+1 wide, all in xext-reg), target
;; "wide" where wide[0]=(low,low-idx), wide[i+1]=(tmp-ext-reg, i) for i in 0..n-1.
;; Use a Cuccaro that selects target bits via a small switch.
(cuccaro-add-joint! c xext-reg 0
low-reg low-idx tmp-ext-reg 0
cin-reg cin-idx (+ n 1))
(gate-cx! c y-reg y-idx cin-reg cin-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c y-reg y-idx xext-reg k)
(loop (+ k 1))))
(gate-x! c y-reg y-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1)))))
;;; Cuccaro-add where the ACCUMULATOR spans two registers: bit 0 lives
;;; at (low-reg, low-idx), bits 1..n-1 live at (mid-reg, mid-off..mid-off+n-2).
;;; Source register has width n, contiguous in src-reg at offset src-off.
(define (joint-acc-ref low-reg low-idx mid-reg mid-off i)
"Return (reg idx) for bit i of the joint accumulator."
(if (= i 0)
(list low-reg low-idx)
(list mid-reg (+ mid-off (- i 1)))))
(define (cuccaro-add-joint! c src-reg src-off
low-reg low-idx mid-reg mid-off
cin-reg cin-idx n)
"acc[0..n) := acc[0..n) + src[src-off..src-off+n), where acc[0]=(low,low-idx)
and acc[i]=(mid-reg, mid-off+i-1) for i>=1. n>=1.
When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path."
(cond
((= n 1)
(gate-cx! c cin-reg cin-idx low-reg low-idx)
(gate-cx! c src-reg src-off low-reg low-idx))
((and *cas-borrowed-carries-reg*
(> *cas-borrowed-carries-width* 0)
(<= (- n 1) *cas-borrowed-carries-width*))
(cuccaro-add-joint-fast-borrowed! c src-reg src-off
low-reg low-idx mid-reg mid-off
cin-reg cin-idx n
*cas-borrowed-carries-reg*
*cas-borrowed-carries-offset*
(cas-alloc-bit-base! n)))
(else
;; MAJ(cin, acc[0], src[0]) — acc[0] = (low, low-idx)
(maj! c cin-reg cin-idx low-reg low-idx src-reg src-off)
(let loop ((i 1))
(when (< i (- n 1))
;; MAJ(src[i-1], acc[i], src[i])
(let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
(maj! c src-reg (+ src-off (- i 1))
(car acc-i) (car (cdr acc-i))
src-reg (+ src-off i)))
(loop (+ i 1))))
;; Final sum bit: acc[n-1] = (mid, mid-off+n-2) since n>=2
(let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1))))
(gate-cx! c src-reg (+ src-off (- n 2))
(car acc-top) (car (cdr acc-top)))
(gate-cx! c src-reg (+ src-off (- n 1))
(car acc-top) (car (cdr acc-top))))
;; Reverse UMA sweep
(let loop ((i (- n 2)))
(when (>= i 1)
(let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
(uma! c src-reg (+ src-off (- i 1))
(car acc-i) (car (cdr acc-i))
src-reg (+ src-off i)))
(loop (- i 1))))
(uma! c cin-reg cin-idx low-reg low-idx src-reg src-off))))
(define (cuccaro-sub-joint! c src-reg src-off
low-reg low-idx mid-reg mid-off
cin-reg cin-idx n)
"Inverse of cuccaro-add-joint!.
When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path."
(cond
((= n 1)
(gate-cx! c src-reg src-off low-reg low-idx)
(gate-cx! c cin-reg cin-idx low-reg low-idx))
((and *cas-borrowed-carries-reg*
(> *cas-borrowed-carries-width* 0)
(<= (- n 1) *cas-borrowed-carries-width*))
(cuccaro-sub-joint-fast-borrowed! c src-reg src-off
low-reg low-idx mid-reg mid-off
cin-reg cin-idx n
*cas-borrowed-carries-reg*
*cas-borrowed-carries-offset*
(cas-alloc-bit-base! n)))
(else
(inv-uma! c cin-reg cin-idx low-reg low-idx src-reg src-off)
(let loop ((i 1))
(when (< i (- n 1))
(let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
(inv-uma! c src-reg (+ src-off (- i 1))
(car acc-i) (car (cdr acc-i))
src-reg (+ src-off i)))
(loop (+ i 1))))
(let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1))))
(gate-cx! c src-reg (+ src-off (- n 1))
(car acc-top) (car (cdr acc-top)))
(gate-cx! c src-reg (+ src-off (- n 2))
(car acc-top) (car (cdr acc-top))))
(let loop ((i (- n 2)))
(when (>= i 1)
(let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
(inv-maj! c src-reg (+ src-off (- i 1))
(car acc-i) (car (cdr acc-i))
src-reg (+ src-off i)))
(loop (- i 1))))
(inv-maj! c cin-reg cin-idx low-reg low-idx src-reg src-off))))
;;; ── cuccaro-add/sub-joint-fast-borrowed! — HMR uncompute, joint acc ─
;;;
;;; Port of HEAD's cuccaro_add_fast pattern to the JOINT accumulator
;;; layout used by schoolbook-row-k0! + sub-x-from-wide!. acc[0] lives
;;; at (low-reg, low-idx); acc[i] for i>=1 lives at (mid-reg, mid-off+i-1).
;;; Source register is contiguous src-reg[src-off..src-off+n).
;;;
;;; Same MAJ-forward / HMR-backward gate sequence as
;;; cuccaro-add-offset-fast-borrowed! (mod-arith.lsp:651) — every acc[i]
;;; reference is translated through joint-acc-ref. src/cin indexing
;;; matches the offset variant exactly (contiguous source).
;;;
;;; Pre: carries-reg[carries-offset..carries-offset+n-2) must be |0> on entry.
;;; Post: carries-reg returns to |0>; src-reg + cin-reg unchanged;
;;; joint acc[0..n) := (acc + src) mod 2^n.
;;; bit-base..bit-base+n-2 are the classical-bit IDs used by HMR uncompute.
(define (cuccaro-add-joint-fast-borrowed! c src-reg src-off
low-reg low-idx mid-reg mid-off
cin-reg cin-idx n
carries-reg carries-offset
bit-base)
"Joint-acc + borrowed-carries port of cuccaro-add-fast-borrowed!.
acc[0]=(low,low-idx); acc[i>=1]=(mid-reg, mid-off+i-1)."
(cond
((= n 0) #t)
((= n 1)
(gate-cx! c cin-reg cin-idx low-reg low-idx)
(gate-cx! c src-reg src-off low-reg low-idx))
(else
;; Forward step i=0: acc[0] = (low, low-idx); src[0]; cin
(gate-cx! c src-reg src-off low-reg low-idx)
(gate-cx! c src-reg src-off cin-reg cin-idx)
(gate-ccx! c cin-reg cin-idx low-reg low-idx
carries-reg carries-offset)
(gate-cx! c carries-reg carries-offset src-reg src-off)
;; Forward steps i=1..n-2: acc[i] = (mid-reg, mid-off+i-1)
(let loop-fwd ((i 1))
(when (< i (- n 1))
(let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
(gate-cx! c src-reg (+ src-off i)
(car acc-i) (car (cdr acc-i)))
(gate-cx! c src-reg (+ src-off i) src-reg (+ src-off (- i 1)))
(gate-ccx! c src-reg (+ src-off (- i 1))
(car acc-i) (car (cdr acc-i))
carries-reg (+ carries-offset i))
(gate-cx! c carries-reg (+ carries-offset i)
src-reg (+ src-off i)))
(loop-fwd (+ i 1))))
;; Final sum bit: acc[n-1] = (mid, mid-off+n-2) for n>=2
(let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1))))
(gate-cx! c src-reg (+ src-off (- n 2))
(car acc-top) (car (cdr acc-top)))
(gate-cx! c src-reg (+ src-off (- n 1))
(car acc-top) (car (cdr acc-top))))
;; Backward HMR uncompute, i = n-2..1
(let loop-back ((i (- n 2)))
(when (>= i 1)
(let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
(gate-cx! c carries-reg (+ carries-offset i)
src-reg (+ src-off i))
(gate-hmr! c carries-reg (+ carries-offset i)
(+ bit-base i))
(gate-push-cond! c (+ bit-base i))
(gate-cz! c src-reg (+ src-off (- i 1))
(car acc-i) (car (cdr acc-i)))
(gate-pop-cond! c)
(gate-cx! c src-reg (+ src-off i) src-reg (+ src-off (- i 1)))
(gate-cx! c src-reg (+ src-off (- i 1))
(car acc-i) (car (cdr acc-i))))
(loop-back (- i 1))))
;; Backward HMR i=0: acc[0] = (low, low-idx)
(gate-cx! c carries-reg carries-offset src-reg src-off)
(gate-hmr! c carries-reg carries-offset bit-base)
(gate-push-cond! c bit-base)
(gate-cz! c cin-reg cin-idx low-reg low-idx)
(gate-pop-cond! c)
(gate-cx! c src-reg src-off cin-reg cin-idx)
(gate-cx! c cin-reg cin-idx low-reg low-idx))))
(define (cuccaro-sub-joint-fast-borrowed! c src-reg src-off
low-reg low-idx mid-reg mid-off
cin-reg cin-idx n
carries-reg carries-offset
bit-base)
"Joint-acc + borrowed-carries port of cuccaro-sub-fast-borrowed!.
acc[0..n) := (acc - src - cin) mod 2^n."
(cond
((= n 0) #t)
((= n 1)
(gate-cx! c src-reg src-off low-reg low-idx)
(gate-cx! c cin-reg cin-idx low-reg low-idx))
(else
;; Forward inv-UMA-like at i=0
(gate-cx! c cin-reg cin-idx low-reg low-idx)
(gate-cx! c src-reg src-off cin-reg cin-idx)
(gate-ccx! c cin-reg cin-idx low-reg low-idx
carries-reg carries-offset)
(gate-cx! c carries-reg carries-offset src-reg src-off)
;; Forward steps i=1..n-2
(let loop-fwd ((i 1))
(when (< i (- n 1))
(let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
(gate-cx! c src-reg (+ src-off (- i 1))
(car acc-i) (car (cdr acc-i)))
(gate-cx! c src-reg (+ src-off i) src-reg (+ src-off (- i 1)))
(gate-ccx! c src-reg (+ src-off (- i 1))
(car acc-i) (car (cdr acc-i))
carries-reg (+ carries-offset i))
(gate-cx! c carries-reg (+ carries-offset i)
src-reg (+ src-off i)))
(loop-fwd (+ i 1))))
;; Final sum bit — sub order swaps the two CXs
(let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1))))
(gate-cx! c src-reg (+ src-off (- n 1))
(car acc-top) (car (cdr acc-top)))
(gate-cx! c src-reg (+ src-off (- n 2))
(car acc-top) (car (cdr acc-top))))
;; Backward HMR uncompute, i = n-2..1
(let loop-back ((i (- n 2)))
(when (>= i 1)
(let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i)))
(gate-cx! c carries-reg (+ carries-offset i)
src-reg (+ src-off i))
(gate-hmr! c carries-reg (+ carries-offset i)
(+ bit-base i))
(gate-push-cond! c (+ bit-base i))
(gate-cz! c src-reg (+ src-off (- i 1))
(car acc-i) (car (cdr acc-i)))
(gate-pop-cond! c)
(gate-cx! c src-reg (+ src-off i) src-reg (+ src-off (- i 1)))
(gate-cx! c src-reg (+ src-off i)
(car acc-i) (car (cdr acc-i))))
(loop-back (- i 1))))
;; Backward HMR i=0
(gate-cx! c carries-reg carries-offset src-reg src-off)
(gate-hmr! c carries-reg carries-offset bit-base)
(gate-push-cond! c bit-base)
(gate-cz! c cin-reg cin-idx low-reg low-idx)
(gate-pop-cond! c)
(gate-cx! c src-reg src-off cin-reg cin-idx)
(gate-cx! c src-reg src-off low-reg low-idx))))
;;; Correction 1 helper: wide[n..2n+1) += y_ext where y_ext = y at bits
;;; [0..n) and pad(=0) at bit n. We need to cuccaro-add the y bits into
;;; a (n+1)-wide slice of wide at offset n. wide[n] = tmp-ext[n-1].
;;; wide[n+1..2n+1) = tmp-ext[n..2n).
;;;
;;; This is the SAME joint accumulator pattern: target bit 0 = (tmp-ext,
;;; n-1), target bits 1..n = (tmp-ext, n..2n-1). Adjacent indices —
;;; really a SINGLE register slice tmp-ext[n-1..2n).
;;;
;;; Source y_ext: we need n+1 bits where y_ext[0..n) = y and y_ext[n] = 0.
;;; We use const-tmp-reg (n+1 wide |0>) as y_ext: copy y into bits [0..n),
;;; run cuccaro-add-offset of const-tmp into tmp-ext at offset n-1 width
;;; n+1, then uncopy y.
(define (cuccaro-add-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg
cin-reg cin-idx const-tmp-reg)
"wide[n..2n+1) += y_ext with c_in present.
wide[n..2n+1) = tmp-ext[n-1..2n)."
;; Copy y → const-tmp low n bits. const-tmp[n] stays |0> = pad.
(let loop ((k 0))
(when (< k n)
(gate-cx! c y-reg k const-tmp-reg k)
(loop (+ k 1))))
;; cuccaro-add at width n+1 into tmp-ext at offset n-1.
(cuccaro-add-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1)
cin-reg cin-idx (+ n 1))
;; Uncopy.
(let loop ((k 0))
(when (< k n)
(gate-cx! c y-reg k const-tmp-reg k)
(loop (+ k 1)))))
(define (cuccaro-sub-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg
cin-reg cin-idx const-tmp-reg)
(let loop ((k 0))
(when (< k n)
(gate-cx! c y-reg k const-tmp-reg k)
(loop (+ k 1))))
(cuccaro-sub-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1)
cin-reg cin-idx (+ n 1))
(let loop ((k 0))
(when (< k n)
(gate-cx! c y-reg k const-tmp-reg k)
(loop (+ k 1)))))
(define (cuccaro-add-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg
cin-reg cin-idx const-tmp-reg)
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k const-tmp-reg k)
(loop (+ k 1))))
(cuccaro-add-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1)
cin-reg cin-idx (+ n 1))
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k const-tmp-reg k)
(loop (+ k 1)))))
(define (cuccaro-sub-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg
cin-reg cin-idx const-tmp-reg)
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k const-tmp-reg k)
(loop (+ k 1))))
(cuccaro-sub-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1)
cin-reg cin-idx (+ n 1))
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k const-tmp-reg k)
(loop (+ k 1)))))
;;; Correction 3 helper: wide -= x, where wide has width 2n+1 ([low ++ tmp-ext])
;;; and x is at x-reg[0..n). x's high (2n+1-n)=n+1 bits are zero (we pad).
;;;
;;; Use a JOINT cuccaro-sub over the full wide. Source: const-tmp at low
;;; n bits (loaded from x) zero-padded above. But const-tmp is only n+1
;;; wide — we need 2n+1 wide source. We allocate xfull internally.
;;;
;;; *sub-x-from-wide-cas-fast* — sweep-027 opt-in flag. When BOTH
;;; *cuccaro-callers-fast* AND this flag are set, widen sb-xfull to
;;; 4n+1 and dispatch joint via cas-borrowed. Disabled by default
;;; (sweep-027 verdict: knife-edge ROI, +10%% worst-case score).
;;; ALLOC width 4n+1 = 1025 at production hits the n=512 ancilla cap
;;; if cap isnt raised — keep off unless cap is also raised.
(define *sub-x-from-wide-cas-fast* #f)
;;; *sub-x-from-wide-host-alloc* — sweep-036 opt-in flag (allocator
;;; surgery). When set, mod-mul-solinas! / mod-mul-solinas-sub! allocate
;;; sb-xfull at Stage-0 (TOP of their scratch suite, BEFORE sb-tmp-ext /
;;; sb-low / sb-xext / sb-const-tmp) instead of letting sub-x-from-wide!
;;; / add-x-into-wide! allocate it internally on each call. The hoisted
;;; alloc lands at the lowest free 513-wide base inside the mod-mul
;;; scope; sub-x-from-wide! / add-x-into-wide! consult *host-sb-xfull-reg*
;;; & skip their internal alloc when that variable is bound. ZERO Toffoli
;;; delta — same sb-xfull contents, same gate sequence. The opt-in is a
;;; pure register-lifetime re-order: it removes the deep-nested late
;;; allocation that landed sb-xfull on top of the dgcd-host floor.
;;;
;;; Predicted peak qubits change: sweep-035 baseline 5,024 → ~4,510
;;; (−10.2 %) per allocator-replay subagent (runs/lumbda-sweep-032
;;; ALLOCATOR-REPORT-sweep030.md temporal-overlap candidate #2).
;;;
;;; When flag off & *host-sb-xfull-reg* #f, both helpers fall through
;;; their old alloc-internal path — byte-identical to sweep-035.
(define *sub-x-from-wide-host-alloc* #f)
;;; Dynamic variable bound by mod-mul-solinas! / mod-mul-solinas-sub!
;;; when *sub-x-from-wide-host-alloc* is on: holds the host-allocated
;;; sb-xfull register name, communicated to sub-x-from-wide! /
;;; add-x-into-wide! without changing their signatures. Cleared to #f
;;; after the Stage-3 inverse pass so subsequent mod-mul calls outside
;;; the host scope alloc internally again.
(define *host-sb-xfull-reg* #f)
;;; sweep-027: when *cuccaro-callers-fast* is set, widen sb-xfull from
;;; 2n+1 → 4n+1 so the top 2n bits can serve as borrowed carries for the
;;; JOINT fast-borrowed dispatch path:
;;;
;;; sb-xfull[0..n) = x data (Stage-1 load)
;;; sb-xfull[n..2n+1) = source pad (touched by cuccaro as |0> bits)
;;; sb-xfull[2n+1..4n+1) = HMR carries pad (clean |0> on entry/exit)
;;;
;;; Width-N=2n+1 joint fast-borrowed consumes N-1 = 2n carries lanes,
;;; which exactly fits sb-xfull[2n+1..4n+1). Bit-base 300000 disjoint
;;; from mod-solinas' 200000 reservation (which covers up to n+1 bits).
;;; Saves (N-1)-N/2 ≈ N-1 = 2n Toffoli per call via HMR uncompute;
;;; cost is +2n qubits in sb-xfull's transient allocation.
(define (sub-x-from-wide! c x-reg n low-reg low-idx tmp-ext-reg
cin-reg cin-idx)
"wide := wide - x, where wide = [low ++ tmp-ext] (2n+1 bits) and x is
at x-reg[0..n). High bits of x_padded are 0. Uses internal xfull
ancilla (alloc'd here; widened to 4n+1 under *cuccaro-callers-fast*
to host the JOINT fast-borrowed carries).
When *host-sb-xfull-reg* is bound (sweep-036 opt-in), the caller
(mod-mul-solinas!) has pre-allocated sb-xfull at outer scope; skip
internal alloc/free & use the hosted register name."
(let* ((use-fast? (and *cuccaro-callers-fast* *sub-x-from-wide-cas-fast*))
(joint-width (+ (* 2 n) 1)) ; N = 2n+1
(carries-need (- joint-width 1)) ; N-1 = 2n
(xfull-width (cond (use-fast? (+ joint-width carries-need))
(else joint-width)))
(host-reg *host-sb-xfull-reg*)
(xfull-name (cond (host-reg host-reg)
(else (quote sb-xfull)))))
;; Allocate xfull (xfull-width bits |0>) — unless hosted by caller.
(when (not host-reg)
(alloc! c xfull-name xfull-width))
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xfull-name k)
(loop (+ k 1))))
;; Configure cas-borrowed for joint dispatch when in fast mode.
(cond
(use-fast?
(let ((saved-reg *cas-borrowed-carries-reg*)
(saved-off *cas-borrowed-carries-offset*)
(saved-base *cas-borrowed-bit-base*)
(saved-width *cas-borrowed-carries-width*))
(set! *cas-borrowed-carries-reg* xfull-name)
(set! *cas-borrowed-carries-offset* joint-width)
(set! *cas-borrowed-bit-base* 300000)
(set! *cas-borrowed-carries-width* carries-need)
(cuccaro-sub-joint! c xfull-name 0
low-reg low-idx tmp-ext-reg 0
cin-reg cin-idx joint-width)
(set! *cas-borrowed-carries-reg* saved-reg)
(set! *cas-borrowed-carries-offset* saved-off)
(set! *cas-borrowed-bit-base* saved-base)
(set! *cas-borrowed-carries-width* saved-width)))
(else
(cuccaro-sub-joint! c xfull-name 0
low-reg low-idx tmp-ext-reg 0
cin-reg cin-idx joint-width)))
;; Uncopy x.
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xfull-name k)
(loop (+ k 1))))
(when (not host-reg)
(free! c xfull-name))))
(define (add-x-into-wide! c x-reg n low-reg low-idx tmp-ext-reg
cin-reg cin-idx)
"Inverse of sub-x-from-wide!: wide += x over full 2n+1 bits.
sb-xfull widened to 4n+1 under *cuccaro-callers-fast* to host
the JOINT fast-borrowed carries pad above the source range.
When *host-sb-xfull-reg* is bound (sweep-036 opt-in), use the hosted
register instead of allocating/freeing internally."
(let* ((use-fast? (and *cuccaro-callers-fast* *sub-x-from-wide-cas-fast*))
(joint-width (+ (* 2 n) 1))
(carries-need (- joint-width 1))
(xfull-width (cond (use-fast? (+ joint-width carries-need))
(else joint-width)))
(host-reg *host-sb-xfull-reg*)
(xfull-name (cond (host-reg host-reg)
(else (quote sb-xfull)))))
(when (not host-reg)
(alloc! c xfull-name xfull-width))
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xfull-name k)
(loop (+ k 1))))
(cond
(use-fast?
(let ((saved-reg *cas-borrowed-carries-reg*)
(saved-off *cas-borrowed-carries-offset*)
(saved-base *cas-borrowed-bit-base*)
(saved-width *cas-borrowed-carries-width*))
(set! *cas-borrowed-carries-reg* xfull-name)
(set! *cas-borrowed-carries-offset* joint-width)
(set! *cas-borrowed-bit-base* 300000)
(set! *cas-borrowed-carries-width* carries-need)
(cuccaro-add-joint! c xfull-name 0
low-reg low-idx tmp-ext-reg 0
cin-reg cin-idx joint-width)
(set! *cas-borrowed-carries-reg* saved-reg)
(set! *cas-borrowed-carries-offset* saved-off)
(set! *cas-borrowed-bit-base* saved-base)
(set! *cas-borrowed-carries-width* saved-width)))
(else
(cuccaro-add-joint! c xfull-name 0
low-reg low-idx tmp-ext-reg 0
cin-reg cin-idx joint-width)))
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xfull-name k)
(loop (+ k 1))))
(when (not host-reg)
(free! c xfull-name))))
;;; Inverse of schoolbook-mul-into-addsub!: undo each correction then
;;; the loop, gate-by-gate inverted. Self-inverse steps (X) re-emit.
(define (schoolbook-mul-into-addsub-inverse! c x-reg y-reg n
low-reg low-idx
tmp-ext-reg
xext-reg cin-reg cin-idx
const-tmp-reg)
;; Reverse correction 4: cuccaro-sub of x_ext at high half.
(cuccaro-sub-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg cin-reg cin-idx
const-tmp-reg)
;; Reverse correction 3: add x back into wide.
(add-x-into-wide! c x-reg n low-reg low-idx tmp-ext-reg cin-reg cin-idx)
;; Reverse correction 2: re-XOR top bit (self-inverse).
(gate-x! c tmp-ext-reg (- (* 2 n) 1))
;; Reverse correction 1: cuccaro-sub of y_ext with cin=1.
(gate-x! c cin-reg cin-idx)
(cuccaro-sub-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg cin-reg cin-idx
const-tmp-reg)
(gate-x! c cin-reg cin-idx)
;; Reverse the main loop (k from n-1 down to 0).
(let loop ((k (- n 1)))
(when (>= k 0)
(cond
((= k 0)
(schoolbook-row-k0-inverse! c x-reg n
y-reg k
low-reg low-idx
tmp-ext-reg
xext-reg cin-reg cin-idx))
(else
(controlled-add-subtract-slice-inverse! c x-reg n
tmp-ext-reg (- k 1)
y-reg k
xext-reg cin-reg cin-idx)))
(loop (- k 1)))))
(define (schoolbook-row-k0-inverse! c x-reg n y-reg y-idx
low-reg low-idx tmp-ext-reg
xext-reg cin-reg cin-idx)
"Inverse of schoolbook-row-k0!."
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1))))
(gate-x! c y-reg y-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c y-reg y-idx xext-reg k)
(loop (+ k 1))))
(gate-cx! c y-reg y-idx cin-reg cin-idx)
(cuccaro-sub-joint! c xext-reg 0
low-reg low-idx tmp-ext-reg 0
cin-reg cin-idx (+ n 1))
(gate-cx! c y-reg y-idx cin-reg cin-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c y-reg y-idx xext-reg k)
(loop (+ k 1))))
(gate-x! c y-reg y-idx)
(let loop ((k 0))
(when (< k n)
(gate-cx! c x-reg k xext-reg k)
(loop (+ k 1)))))
;;; ── mod-mul! — Litinski wide schoolbook + Solinas-style reduction ─
;;;
;;; Calling convention:
;;; a-reg, b-reg, out-reg : (n+1)-wide; top bit must be |0> on entry
;;; (we operate on low n bits only).
;;; a-reg, b-reg preserved; out-reg ends with
;;; (a*b) mod p.
;;; cin-reg, cin-idx : 1 bit |0> in/out (mod-add c_in)
;;; tmp-reg : (n+1)-wide |0> in/out — mod-add's inner
;;; constant-loading scratch.
;;; flag-reg, flag-idx : 1 bit |0> in/out (mod-add flag)
;;; red-tmp-reg : (n+1)-wide |0> in/out — used in Stage 2 to
;;; load 2^k mod p constants into a register
;;; before mod-add into out.
;;;
;;; Inside, mod-mul! allocates its own Litinski scratch:
;;; sb-tmp-ext (2n bits) the wide product accumulator
;;; sb-low (1 bit) wide[0]
;;; sb-xext (n+1 bits) controlled-add-subtract scratch
;;; sb-const-tmp (n+1 bits) correction-stage constant-loading scratch
;;; sb-xfull (2n+1 bits, alloc/free'd inside sub-x-from-wide!)
;;; ── Solinas dispatch flag ─────────────────────────────────────
;;;
;;; When *mod-mul-use-solinas* is non-#f, mod-mul! and mod-mul-sub!
;;; dispatch into mod-mul-solinas! / mod-mul-solinas-sub! (defined in
;;; lumbda/mod-solinas.lsp — caller must load that file before flipping
;;; the flag). Caller-visible signatures and ancilla register names
;;; remain identical, so every consumer (mod-inv!, mod-square!,
;;; real-point-add!) inherits the speedup without code change.
(define *mod-mul-use-solinas* #f)
(define (mod-mul! c a-reg b-reg out-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx
red-tmp-reg)
"out := (a * b) mod p. Litinski schoolbook + per-bit Solinas-style reduce.
See header for full calling convention.
When *mod-mul-use-solinas* is non-#f, dispatch to mod-mul-solinas!
(mod-solinas.lsp must already be loaded)."
(cond
(*mod-mul-use-solinas*
(mod-mul-solinas! c a-reg b-reg out-reg n+1 p
(compute-c-expansion p (- n+1 1))
cin-reg cin-idx tmp-reg flag-reg flag-idx
red-tmp-reg))
(else
(mod-mul-litinski! c a-reg b-reg out-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx
red-tmp-reg))))
;;; ── mod-mul-from-zero! — caller-explicit out=|0> specialization ───
;;;
;;; Port of HEAD's `mod_add_qq_fast_from_zero` lifted to the multiply
;;; entry boundary. Caller invokes this INSTEAD of mod-mul! when out-reg
;;; is provably |0> on entry (e.g. mod-square!'s freshly-alloc'd out,
;;; mod-inv-by Fermat ladder's r-next / b-next, point-add lam-reg before
;;; any accumulation).
;;;
;;; Saves n CCX per fresh-multiply when both
;;; *mod-mul-use-solinas* AND *mod-mul-from-zero-first-add*
;;; are #t. When *mod-mul-from-zero-first-add* off, byte-identical to
;;; mod-mul-solinas! (safe fallback). When *mod-mul-use-solinas* off,
;;; falls through to mod-mul-litinski! (no specialization yet for the
;;; Litinski path — Stage 2 dispatch shape differs).
(define (mod-mul-from-zero! c a-reg b-reg out-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx
red-tmp-reg)
"out := (a * b) mod p when out is |0> on entry. See mod-mul! header
for calling convention."
(cond
(*mod-mul-use-solinas*
(mod-mul-solinas-from-zero! c a-reg b-reg out-reg n+1 p
(compute-c-expansion p (- n+1 1))
cin-reg cin-idx tmp-reg flag-reg flag-idx
red-tmp-reg))
(else
(mod-mul-litinski! c a-reg b-reg out-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx
red-tmp-reg))))
(define (mod-mul-litinski! c a-reg b-reg out-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx
red-tmp-reg)
"Original Litinski wide-schoolbook + per-bit Solinas reduce. Renamed
from mod-mul! so we can preserve the original code path for
regression testing while mod-mul! itself becomes the dispatcher."
(let ((n (- n+1 1)))
(cond
((= n 0) #t) ; degenerate, nothing to do
(else
;; ── Stage 0: alloc Litinski scratch ──
(alloc! c (quote sb-tmp-ext) (* 2 n))
(alloc! c (quote sb-low) 1)
(alloc! c (quote sb-xext) (+ n 1))
(alloc! c (quote sb-const-tmp) (+ n 1))
;; ── Stage 1: compute wide product sb-tmp-ext := a * b ──
(schoolbook-mul-into-addsub! c a-reg b-reg n
(quote sb-low) 0
(quote sb-tmp-ext)
(quote sb-xext)
cin-reg cin-idx
(quote sb-const-tmp))
;; ── Stage 2: reduce sb-tmp-ext mod p into out ──
;; For each bit k in [0, 2n): if sb-tmp-ext[k]=1 then
;; out += (2^k mod p) mod p.
;; Reversible via cload-const + mod-add + cunload-const, where the
;; constant lives in red-tmp-reg (n+1 wide, top bit |0>).
(let loop ((k 0))
(when (< k (* 2 n))
(let ((c-k (modulo (expt 2 k) p)))
(when (> c-k 0) ; skip no-op constants
;; Load c-k into red-tmp controlled on sb-tmp-ext[k].
(cload-const! c (quote sb-tmp-ext) k red-tmp-reg n+1 c-k)
;; Add red-tmp into out mod p.
(mod-add! c red-tmp-reg out-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
;; Unload c-k.
(cunload-const! c (quote sb-tmp-ext) k red-tmp-reg n+1 c-k)))
(loop (+ k 1))))
;; ── Stage 3: uncompute sb-tmp-ext back to |0> ──
(schoolbook-mul-into-addsub-inverse! c a-reg b-reg n
(quote sb-low) 0
(quote sb-tmp-ext)
(quote sb-xext)
cin-reg cin-idx
(quote sb-const-tmp))
;; ── Stage 4: free Litinski scratch ──
(free! c (quote sb-const-tmp))
(free! c (quote sb-xext))
(free! c (quote sb-low))
(free! c (quote sb-tmp-ext))))))
;;; ── mod-double-inplace! — v := 2v mod p, (n+1)-wide register ──
;;;
;;; Mirrors upstream's mod_double_inplace at mod.rs:2769.
;;;
;;; Pattern (cost: O(n) gates):
;;; 1. Shift-left v by 1 via SWAP cascade. Caller's (n+1)-wide v-reg
;;; starts as [v_0 v_1 ... v_{n-1} 0]; after the cascade we have
;;; [0 v_0 v_1 ... v_{n-1}]. Now v-reg = T = 2 * v_orig in [0, 2p).
;;; 2. Add c = 2^n - p across the full (n+1) bits. Sum S = T + c.
;;; Top bit (idx n) of S is set iff T >= p.
;;; 3. flag := S[n] via CX.
;;; 4. csub c controlled on (NOT flag) — undoes the add when no reduction.
;;; 5. CX flag -> S[n] — clears the top bit when reduction needed.
;;; 6. Uncompute flag: T is even (= 2v), p is odd → after reduction v[0]=1;
;;; no reduction → v[0]=0. So flag == v[0]. CX v[0] -> flag clears.
;;;
;;; All ancillae (cin, tmp, flag) return to |0>. v-reg top bit returns to |0>.
;;; Caller-supplied ancillae: cin (1 bit), tmp (n+1 wide), flag (1 bit).
;;;
;;; Variant choice: in-place via swap cascade + Solinas-style fold.
;;; Chosen because it mirrors upstream byte-for-byte; alternative
;;; Bennett-style "double via mod-add of copy" requires a 2^{-1} mod p
;;; classical inversion AND a fresh ancilla — heavier than this one
;;; ovf-bit pattern in lumbda. See task spec §"variant choice".
;;;
;;; SWAP not in our gate set — implemented as 3 CX (a→b, b→a, a→b).
(define (gate-swap! c a-reg a-idx b-reg b-idx)
"SWAP qubit a with b via three CXs. Self-inverse."
(gate-cx! c a-reg a-idx b-reg b-idx)
(gate-cx! c b-reg b-idx a-reg a-idx)
(gate-cx! c a-reg a-idx b-reg b-idx))
;;; ── pseudo-Mersenne mod-double (Schrottenloher 2026 Algorithm 7) ─
;;;
;;; For pseudo-Mersenne primes p = 2^u - f with f << 2^u (secp256k1: u=256,
;;; f=2^32+977=4294968273, 33 bits) the entire add-const / csub-const /
;;; flag-uncompute dance collapses to a single controlled add of f over the
;;; LOW lsbs bits of v, controlled on the carry-out from the shift.
;;;
;;; Algorithm 7 (qarton special_mod_arithmetic.py:54-92):
;;; 1. shift v left by 1 (anc receives MSB carry-out)
;;; 2. cadd(anc, f, v[:lsbs]) — controlled add of f into low lsbs bits
;;; 3. cx(v[0], anc) — uncompute anc via parity
;;;
;;; Correctness lsbs = padding + bit_length(f). The cadd carry walks at most
;;; lsbs bits; if it would propagate further, the result is wrong. For
;;; uniform random v the failure probability is roughly 2^(-padding). Qarton
;;; uses padding=30 by default — same as Schrottenloher §4.
;;;
;;; Toffoli savings vs control: control mod-double-inplace! emits one
;;; add-const + one csub-const, both at full width (n+1). Each cuccaro-add
;;; over k bits costs 2(k-1) Toffoli (HEAD's HMR-borrowed variant: k-1).
;;; Pseudo-Mersenne emits ONE cadd-const at width lsbs only. Predicted
;;; Toffoli savings at secp256k1 width: ≈ 2 × (n+1 - lsbs) / (2(n+1)) ≈
;;; (256 - 63) / 257 ≈ 75 % of mod-double Toffoli; mod-double itself sits
;;; at ~8 % of total (Schrottenloher Table 3) → predicted 5-10 % full-stack.
(define *mod-double-use-pseudo-mersenne* #f)
;;; *mod-double-pseudo-mersenne-padding* — extra carry-safety bits beyond
;;; bit_length(f) for the controlled add. Larger padding → smaller flake
;;; probability ≈ 2^(-padding) but more Toffoli per call. Qarton + paper
;;; both use 30 by default.
(define *mod-double-pseudo-mersenne-padding* 30)
;;; *windowed-mod-double-r* — sweep-windowed-mod-double-r dispatcher.
;;; When #t, mod-double-inplace! routes through mod-double-inplace-
;;; windowed! (HEAD modular.rs:417-419 windowed branch). Foundation for
;;; K=5 apply-phase split — HEAD's compressed.rs:1986-1999 + 2515
;;; lean on the windowed form for the q1192 island. Default #f preserves
;;; byte-identity for every existing caller. Truncation flake
;;; probability ≈ 2^-(window+1) per call (window pulled from
;;; *windowed-mod-double-r-window*, default 8 matching HEAD).
;;;
;;; Composes with neither *mod-double-use-pseudo-mersenne* nor the
;;; alg-11 safe-band detector — the windowed path is its own dispatch
;;; branch (highest-priority) in mod-double-inplace!.
(define *windowed-mod-double-r* #f)
(define *windowed-mod-double-r-window* 8)
(define (pmersenne-bit-length n)
"Number of bits to represent positive integer n (== Python's int.bit_length).
bit-length(0)=0, bit-length(1)=1, bit-length(2)=2, bit-length(3)=2, ..."
(let loop ((k 0) (m n))
(if (= m 0) k (loop (+ k 1) (quotient m 2)))))
(define (mod-double-inplace-pseudo-mersenne!
c v-reg n+1 p pmersenne-f
cin-reg cin-idx tmp-reg flag-reg flag-idx)
"Pseudo-Mersenne variant of mod-double-inplace!. Same calling convention
(v-reg (n+1) wide, cin/tmp/flag scratch); ignores flag-reg/flag-idx
(kept for signature compatibility with the dispatcher).
pmersenne-f = 2^n - p (must be > 0 and small)."
(let* ((n (- n+1 1))
(f-bits (pmersenne-bit-length pmersenne-f))
(padding *mod-double-pseudo-mersenne-padding*)
(lsbs (min n+1 (+ padding f-bits))))
;; (1) Shift-left v in place via SWAP cascade.
;; End state: bit 0 = 0, bit i (i>=1) = v_orig[i-1],
;; bit n = v_orig[n-1] = pseudo-Mersenne carry-out.
(let loop ((i n))
(when (> i 0)
(gate-swap! c v-reg i v-reg (- i 1))
(loop (- i 1))))
;; (2) cadd(anc=v[n], f, v[0..lsbs)) — controlled add of f into low bits.
;; No aliasing concern: ctrl-idx = n, tgt-idx range = [0, lsbs) with
;; lsbs < n+1, so ctrl bit never overlaps with cadd's target slice.
(cadd-const! c v-reg lsbs pmersenne-f
v-reg n cin-reg cin-idx tmp-reg)
;; (3) Uncompute anc via parity: 2v is even, p is odd → after reduction
;; v[0] = 1, no reduction → v[0] = 0. CX v[0] -> v[n] clears anc.
(gate-cx! c v-reg 0 v-reg n)))
;;; ── mod-halve-inplace-direct-const-fast! ──────────────────────────
;;;
;;; Port of HEAD mod_halve_inplace_direct_const_fast
;;; (src/point_add/arith/modular.rs:753-765, commit 2dcf00d). Gate-level
;;; inverse of mod_double_inplace_direct_const_fast (sweep-030 PORTED
;;; in lumbda as mod-double-inplace-pseudo-mersenne!). Closes the open
;;; question sweep-030 RESULTS.md flagged + the mod-add-double-qb
;;; PORTED-WITH-GAP from sweep-mod-qb-adders.
;;;
;;; HEAD algorithm (5 steps):
;;; 1. alloc ovf qubit
;;; 2. cx(v[0], ovf) -- XOR LSB into ovf
;;; 3. csub_nbit_const_direct_fast(v, c, ovf) where c = 2^n - p
;;; 4. swap chain: for i in 0..n-1: swap(v[i], v[i+1]) (right rotate)
;;; 5. swap(v[n-1], ovf); free ovf -- ovf bit lands at v[n-1]
;;;
;;; This is the EXACT gate-level inverse of the direct-const double
;;; (HEAD line 408+): the double's pre-shift swap-chain becomes the
;;; halve's post-shift swap-chain; the double's cadd becomes the
;;; halve's csub; the double's parity-uncompute becomes the halve's
;;; parity-cx-INTO-ovf at the start.
;;;
;;; Substrate status: ADDITIVE. No lumbda caller dispatches through
;;; this primitive yet. mod-add-double-qb (sweep-mod-qb-adders) can
;;; route through this once a follow-on sweep adds the dispatcher
;;; flag (analog of HEAD's KAL_DIRECT_CONST_HALVE / direct_const_
;;; walks_enabled).
;;;
;;; Caller supplies the 'mod-halve-anc qubit + carries lane via cin/
;;; tmp/flag (HEAD allocs inline; lumbda style routes through args).
;;; ── mod-double-inplace-direct-const-fast! — sweep-sq-lowq-shift22 ──
;;;
;;; HEAD modular.rs:414. Mirror of mod-halve-inplace-direct-const-fast!
;;; with cadd direction. Uses cadd-nbit-const-direct-fast! (PORTED in
;;; sweep-cadd-csub-direct-fast) for the Solinas correction.
(define (mod-double-inplace-direct-const-fast!
c v-reg n+1 p pmersenne-f
cin-reg cin-idx tmp-reg flag-reg flag-idx)
"Port of HEAD mod_double_inplace_direct_const_fast (modular.rs:414).
v-reg := 2*v mod p (in place). v-reg is (n+1)-wide; v in low n bits,
v[n] = ovf at |0> on entry + restored on exit. pmersenne-f = 2^n - p."
(let* ((n (- n+1 1))
(c-const pmersenne-f))
;; (1) swap(v[n-1], v[n]).
(gate-swap! c v-reg (- n 1) v-reg n)
;; (2) Right-rotate the n low bits via reverse swap chain.
(let loop ((i (- n 2)))
(when (>= i 0)
(gate-swap! c v-reg i v-reg (+ i 1))
(loop (- i 1))))
;; (3) cadd-nbit-const-direct-fast! ctrl=v[n] (ovf) into v[0..n].
(cadd-nbit-const-direct-fast!
c v-reg n c-const v-reg n tmp-reg (* 4 n+1))
;; (4) Parity CX: v[0] XOR into v[n] (clears ovf).
(gate-cx! c v-reg 0 v-reg n)))
;;; ── mod-double-inplace-windowed! — sweep-windowed-mod-double-r ──
;;;
;;; Port of HEAD `mod_double_inplace_fast_with_dirty`
;;; (modular.rs:398-444), windowed branch (lines 417-419 — fires when
;;; `double_carry_trunc_window()` returns `Some(w)` i.e. env var
;;; `KAL_DOUBLE_CARRY_TRUNC_W=w`). HEAD's K=5 apply-phase ipmul +
;;; quotient bodies (compressed.rs:1986-1999 + 2515) lean on this
;;; windowed form for the q1192 island; the apply-phase callsite
;;; allocates an `ovf` qubit, swaps the top bit out, right-rotates the
;;; low n bits, then runs ONE truncated cadd against ctrl=ovf instead
;;; of the standard add-const + csub-const + flag-uncompute pair.
;;;
;;; Structural shape vs `mod-double-inplace-direct-const-fast!`:
;;;
;;; • direct-const-fast emits a FULL-width `cadd-nbit-const-direct-fast!`
;;; (no carry-tail truncation; exact for any v).
;;; • windowed emits `cadd-nbit-const-direct-trunc-fast!` with carry
;;; ripple stopped `window` bits past `highest_set_bit(c)`.
;;; For secp256k1, c = 2^32 + 977 has highest-bit 32; window=8 stops
;;; the ripple at bit 40 — saves ~(n - 40) carry maj-recurrence
;;; CCXs + the matching backward HMR sweep per call. Per-call
;;; Toffoli drops from ~2(n-1) to ~2*(highest_set_bit(c) + w).
;;;
;;; Flake probability: ~2^-(window+1) per call. At window=8 that's
;;; ~2^-9 ≈ 0.2 %. Production cells stack the apply-phase fold's same
;;; window so forward + reverse use matching truncation; mismatch only
;;; manifests when the carry-tail propagates through `window + 1`
;;; consecutive 1-bits in the running accumulator above bit 32 — the
;;; "exact-unless-rare-input" regime documented in HEAD's
;;; cadd_nbit_const_direct_trunc_fast docstring (const_arith.rs:526).
;;;
;;; Calling convention matches `mod-double-inplace!`:
;;; v-reg : (n+1)-wide; v in low n bits, bit n at |0> in/out.
;;; p : prime; classical.
;;; pmersenne-f : 2^n - p (HEAD's `c`). Caller computes once.
;;; tmp-reg : (>= last+1)-wide ancilla at |0> for the carries lane.
;;; `last = min(n-2, highest-set-bit(f) + window)`.
;;;
;;; Width assertion: caller must pass tmp-reg with capacity >= last+1.
;;; All existing dispatchers route mod-double-inplace! with tmp-reg
;;; sized n+1 — which is always >= last+1 since last <= n-2.
(define (mod-double-inplace-windowed!
c v-reg n+1 p pmersenne-f
cin-reg cin-idx tmp-reg flag-reg flag-idx window)
"Port of HEAD mod_double_inplace_fast_with_dirty windowed branch
(modular.rs:417-419). v-reg := 2*v mod p (in place) via shift-cascade
+ ONE truncated cadd. Saves ~(n - hi - window) carry-sweep CCXs per
call vs the non-windowed direct-const path.
v-reg : (n+1)-wide; v in low n bits, bit n at |0> in/out.
pmersenne-f : 2^n - p (HEAD's `c`).
window : carry-tail safety bits past highest_set_bit(pmersenne-f).
HEAD's default 8 — flake prob ~2^-(window+1) per call.
cin-reg/cin-idx + flag-reg/flag-idx kept for signature parity; the
windowed path does NOT use them (no separate flag ancilla — ovf
lives at v[n] post-shift)."
(let* ((n (- n+1 1))
(c-const pmersenne-f))
;; (1) swap(v[n-1], v[n]).
(gate-swap! c v-reg (- n 1) v-reg n)
;; (2) Right-rotate the n low bits via reverse swap chain.
(let loop ((i (- n 2)))
(when (>= i 0)
(gate-swap! c v-reg i v-reg (+ i 1))
(loop (- i 1))))
;; (3) cadd-nbit-const-direct-trunc-fast! ctrl=v[n] (ovf) into v[0..n).
;; Unique bit-base via cdtf-alloc-bit-base! so back-to-back calls
;; in K=2 shift2=1 path don't collide on HMR slots.
(cadd-nbit-const-direct-trunc-fast!
c v-reg n c-const v-reg n tmp-reg window (cdtf-alloc-bit-base! n))
;; (4) Parity CX: v[0] XOR into v[n] (clears ovf).
(gate-cx! c v-reg 0 v-reg n)))
(define (mod-halve-inplace-direct-const-fast!
c v-reg n+1 p pmersenne-f
cin-reg cin-idx tmp-reg flag-reg flag-idx)
;; v-reg := v / 2 mod p (in place). v-reg is (n+1)-wide; v in low n
;; bits, bit n at |0> on entry + restored to |0> on exit (the ovf
;; ancilla). pmersenne-f = 2^n - p (matches mod-double-inplace-
;; pseudo-mersenne! caller convention). flag-reg/flag-idx kept for
;; signature symmetry with the dispatcher.
(let* ((n (- n+1 1))
(c-const pmersenne-f)) ; c = 2^n - p; HEAD line 757 same form
;; (1) Parity CX: v[0] XOR into v[n] (our ovf is at v[n]).
(gate-cx! c v-reg 0 v-reg n)
;; (2) Controlled sub of c, ctrl = v[n] (= ovf).
;; csub-nbit-const-direct-trunc-fast! with window = n is
;; effectively non-truncated (no carry-tail truncation).
(csub-nbit-const-direct-trunc-fast!
c v-reg n c-const v-reg n tmp-reg n (* 4 n+1))
;; (3) Right-rotate the n low bits via swap chain. Matches HEAD's
;; for i in 0..n-1: swap(v[i], v[i+1]).
(let loop ((i 0))
(when (< i (- n 1))
(gate-swap! c v-reg i v-reg (+ i 1))
(loop (+ i 1))))
;; (4) Final swap: v[n-1] <-> ovf (v[n]). ovf-content lands at
;; v[n-1]; v[n] returns to |0> (the bit that came from v[n-1]
;; after step 3's chain).
(gate-swap! c v-reg (- n 1) v-reg n)))
(define (mod-double-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
"v-reg := 2 * v-reg mod p (in place). v-reg is (n+1)-wide; v stored in
low n bits, bit n starts |0> and ends |0>. cin/tmp/flag are the same
scratch suite used by mod-add!: cin (1), tmp (n+1), flag (1), all |0>
in/out. Cost: 1 cuccaro-add (the inner add-const) + 1 cuccaro-sub
(csub-const) + 5n + O(1) Clifford gates. O(n) total.
When *mod-double-use-pseudo-mersenne* is #t AND p is a pseudo-Mersenne
prime (f = 2^n - p small), dispatches to mod-double-inplace-pseudo-mersenne!."
(let* ((n (- n+1 1))
(c-const (- (expt 2 n) p))
(f-bits (pmersenne-bit-length c-const))
(padding *mod-double-pseudo-mersenne-padding*))
(cond
;; sweep-windowed-mod-double-r: HEAD modular.rs:417-419 windowed
;; branch. Routes through mod-double-inplace-windowed! (one
;; truncated cadd; no separate flag-ancilla / csub pair). Highest
;; priority — composes with neither the pseudo-Mersenne path nor
;; alg-11 safe-band. Default OFF for byte-identity.
((and *windowed-mod-double-r* (> c-const 0))
(mod-double-inplace-windowed!
c v-reg n+1 p c-const cin-reg cin-idx tmp-reg
flag-reg flag-idx *windowed-mod-double-r-window*))
;; Dispatch to pseudo-Mersenne when flag on AND f is small enough
;; that lsbs = padding + f-bits stays strictly below n+1 (otherwise
;; the no-aliasing assumption breaks).
;;
;; 2026-06-12 — DISABLED pseudo-Mersenne. Same bug class as
;; mod-add-inplace-pseudo-mersenne! (commit 5e6e3af). Reducer
;; tests/sweep-doctrine/test-mod-double-top-bit-clean.lsp at
;; n+1=8, p=125 (non-Mersenne, bug range non-empty): v=63 →
;; got 126, expected 1. ARITH-FAIL with top bit clean (worse
;; than mod-add — silent wrong-output, no leak diagnostic).
;;
;; Root cause: step 1's shift-left captures v[n] = v_orig[n-1]
;; as the overflow indicator. This only fires when 2v ≥ 2^n,
;; not when 2v ≥ p. For v_orig ∈ [p/2, 2^(n-1)) where 2v ∈ [p,
;; 2^n), the algorithm doesn't reduce and step 3's parity-CX
;; doesn't fix it (v[0]=0 since 2v is even, no XOR).
;;
;; Standard mod-double-inplace! (else branch) uses full csub-
;; const-based reduction, provably correct, drop-in replacement.
;; Trade-off: more Toffolis but algorithmically sound.
;;
;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on,
;; mod-double-alg-11-safe? classically peeks v-reg & routes
;; pseudo-Mersenne only when 2v < p OR 2v >= 2^n (the safe regimes
;; outside the [p, 2^n) bug band).
((and *mod-double-use-pseudo-mersenne*
(> c-const 0)
(< (+ padding f-bits) n+1)
(mod-double-alg-11-safe? c v-reg n+1 p))
(mod-double-inplace-pseudo-mersenne!
c v-reg n+1 p c-const cin-reg cin-idx tmp-reg flag-reg flag-idx))
(else
;; (1) Shift-left v in place via SWAP cascade.
;; End state: bit 0 = 0, bit i (i>=1) = v_orig[i-1], bit n = v_orig[n-1].
;; Walk from top down: swap(v[n], v[n-1]), swap(v[n-1], v[n-2]), ...
(let loop ((i n))
(when (> i 0)
(gate-swap! c v-reg i v-reg (- i 1))
(loop (- i 1))))
;; (2) Add c = 2^n - p at width n+1.
(add-const! c v-reg n+1 c-const cin-reg cin-idx tmp-reg)
;; (3) flag := v[n]
(gate-cx! c v-reg n flag-reg flag-idx)
;; (4) X flag so flag=1 when NO reduction needed; csub-const controlled.
(gate-x! c flag-reg flag-idx)
(csub-const! c v-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg)
(gate-x! c flag-reg flag-idx)
;; (5) CX flag -> v[n] (clears top bit when reduction happened)
(gate-cx! c flag-reg flag-idx v-reg n)
;; (6) Uncompute flag via parity: flag == v[0]
(gate-cx! c v-reg 0 flag-reg flag-idx)))))
;;; ── mod-4x-inplace! — v := 4v mod p, sweep-apply-fused-fold sibling ─
;;;
;;; HEAD reference: `compressed.rs:2149-2281` `dialog_gcd_fused_double_y`.
;;; Lumbda hooks: STEP 7+8 dispatch under K=2 + apply-fused-fold flags
;;; at `mod-inv-by-dialog-gcd-host.lsp` ~line 345.
;;;
;;; Semantics: v := 4v mod p on a SINGLE shared carry chain (target).
;;; v-reg is (n+1)-wide; v stored in low n bits, bit n |0> in/out.
;;; cin/tmp/flag scratch reused across both folds (no extra ancilla
;;; vs `mod-double-inplace!` × 2). Classical-specialization at the
;;; caller — this primitive ships only when the classical Kaliski
;;; trace says shift2-bit = 1 for this iter; otherwise the caller
;;; emits one `mod-double-inplace!`.
;;;
;;; V1 (prior): sequential two-fold via two `mod-double-inplace-pseudo-
;;; mersenne!` calls — substrate vehicle but byte-identical to inline
;;; K=2 pattern. Shipped 2.0228e+10 at i258 (non-K2body).
;;;
;;; V2 (this commit): inlined dual-shift + explicit ovf1/ovf2 ancilla
;;; capture + two cadd-const calls sharing the cin/tmp carry buffer.
;;; Matches HEAD's STRUCTURAL layout (compressed.rs:2149-2281) — ovf1
;;; held in a side ancilla across shift2; ovf2 captured post-shift2;
;;; one cadd-const(f, ctrl=ovf1) + one cadd-const(2f, ctrl=ovf2) at
;;; width lsbs+1. Parity uncompute of ovf1/ovf2 from v[0]/v[1] post-fold.
;;;
;;; V2 buys substrate clarity, not Toffoli: the two carry sweeps remain
;;; physically distinct (lumbda lacks a per-position-controls cadd
;;; helper). Per-iter Toffoli ≈ V1 (≤ ±2 from extra ovf-uncompute CCX).
;;; Production score targets a small change vs V1 baseline; the true
;;; -8k..-16k Toff/shot saving rides on V2.5 — a new
;;; `cadd-2-controls-trunc-fast!` primitive that emits HEAD's 12-position
;;; controlled-add (compressed.rs:2193-2215) at width lsbs. V2 substrate
;;; positions ovf1/ovf2 in named ancilla so V2.5 lands as a single
;;; cadd-call replacement.
;;;
;;; Algorithm trace (n=256, secp256k1, c = 2^256 - p):
;;; 1. alloc ovf1 ancilla.
;;; 2. shift1 (swap cascade): v[n] := v_orig[n-1], v[0] := 0.
;;; 3. swap(v[n], ovf1): ovf1 := v_orig[n-1], v[n] := 0.
;;; 4. alloc ovf2 ancilla.
;;; 5. shift2 (swap cascade): v[n] := v_orig[n-2], v[0] := 0.
;;; (Note v[0] entering shift2 was 0 post step 3; so v[0]=0 post.)
;;; 6. swap(v[n], ovf2): ovf2 := v_orig[n-2], v[n] := 0.
;;; 7. cadd-const(v, lsbs, f, ctrl=ovf1, cin/tmp): v += f · ovf1.
;;; 8. cadd-const(v, lsbs, 2f, ctrl=ovf2, cin/tmp): v += 2f · ovf2.
;;; Same width as #7; padding leaves plenty of carry headroom
;;; inside lsbs even though 2f has 1 more bit than f.
;;; 9. Parity uncompute ovf1: post-fold v[0] = ovf1 (f bit 0 = 1, 2f
;;; bit 0 = 0 → v[0] = ovf1·1 + ovf2·0 = ovf1). CX v[0] → ovf1.
;;; 10. Parity uncompute ovf2: post-fold v[1] = ovf1·f[1] + ovf2·(2f)[1]
;;; mod 2 = ovf1·f[1] + ovf2·f[0] = ovf1·f[1] + ovf2. When f[1]=0
;;; (secp256k1: f=2^32+977, f[1]=0), v[1] = ovf2. CX v[1] → ovf2.
;;; For general f, when f[1]=1 we'd need an extra CX ovf1 → ovf2
;;; to absorb the f[1]·ovf1 term. Guarded explicitly below.
;;; 11. free ovf2, ovf1.
;;;
;;; Safety: errors when classical *dgcd-k2-bounded-shift* off.
(define (mod-4x-inplace! c v-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
"v-reg := 4 * v-reg mod p (in place). v-reg is (n+1)-wide; v stored
in low n bits, bit n starts |0> and ends |0>. Same scratch suite as
mod-double-inplace!.
When *mod-double-use-pseudo-mersenne* is #t AND p is a pseudo-Mersenne
prime (f = 2^n - p small), uses the V2 inlined dual-shift +
ovf-capture path with two cadd-const calls sharing cin/tmp. Otherwise
falls back to two mod-double-inplace! calls (general Solinas path).
Defensive guard: errors when *dgcd-k2-bounded-shift* is off, since
the host dispatch only emits this primitive when classical K=2 trace
says shift2-bit=1 — calling it standalone outside that flow is a
contract violation (would multiply v by 4 with no matching
shift2-on-v_w under the iter).
v-reg must be a named register (symbol). Allocates two ancilla
registers `_4x-ovf1` and `_4x-ovf2` (1 bit each) — distinct from
caller-supplied scratch so no aliasing risk. Both return to |0>."
(cond
((not *dgcd-k2-bounded-shift*)
(error "mod-4x-inplace! requires *dgcd-k2-bounded-shift* #t"))
(else
(let* ((n (- n+1 1))
(c-const (- (expt 2 n) p))
(f-bits (pmersenne-bit-length c-const))
(padding *mod-double-pseudo-mersenne-padding*)
(lsbs (min n+1 (+ padding f-bits))))
(cond
;; ── V2: pseudo-Mersenne dual-shift + ovf-capture ──
;; Pseudo-Mersenne fast path when f small enough for lsbs < n+1
;; AND f[1] = 0 (so post-fold v[1] = ovf2 cleanly with no
;; cross-term f[1]·ovf1). For secp256k1 f = 2^32 + 977 with
;; bit 1 = 0; for small-width probe p=11 f=5 with bit 1 = 0; both
;; OK. For f[1]=1 primes we fall back to V1 path.
((and *mod-double-use-pseudo-mersenne*
(> c-const 0)
(< (+ padding f-bits) n+1)
(not (bit-set? c-const 1)))
(let ((ovf1 '_4x-ovf1)
(ovf2 '_4x-ovf2))
(alloc! c ovf1 1)
(alloc! c ovf2 1)
;; (1) shift1 swap cascade — v[n] := v_orig[n-1], v[0] := 0.
(let loop ((i n))
(when (> i 0)
(gate-swap! c v-reg i v-reg (- i 1))
(loop (- i 1))))
;; (2) capture ovf1: swap(v[n], ovf1). v[n] := 0, ovf1 := v_orig[n-1].
(gate-swap! c v-reg n ovf1 0)
;; (3) shift2 swap cascade — v[n] := v_orig[n-2], v[0] := 0
;; (v[0] was 0 post step 1; remains 0 post step 3 since
;; each swap pushes the existing v[i-1] up).
(let loop ((i n))
(when (> i 0)
(gate-swap! c v-reg i v-reg (- i 1))
(loop (- i 1))))
;; (4) capture ovf2: swap(v[n], ovf2). v[n] := 0, ovf2 := v_orig[n-2].
(gate-swap! c v-reg n ovf2 0)
;; (5+6) V2.5 fused fold: v[0..lsbs) += f·ovf1 + 2f·ovf2 in
;; ONE truncated carry sweep via per-position-controls
;; primitive. Replaces V2's two sequential cadd-const!
;; calls (which each emitted a full Solinas ripple).
;; Derives 4 ancilla (h, xed, eord, n10) from ovf1/ovf2,
;; issues 1 truncated ripple at width lsbs, uncomputes
;; the ancilla. Net save ~58 Toff/call vs V2.
;; Hardcoded for secp256k1 c = 2^32+977 table (HEAD
;; compressed.rs:2196-2210). Pre-guard via lsbs check.
(cond
((and (> lsbs (+ (highest-set-bit c-const) 2))
*cadd-direct-trunc-fast*)
(cadd-2-controls-trunc-fast!
c v-reg lsbs
c-const ovf1 0
(* 2 c-const) ovf2 0
tmp-reg
*cadd-direct-window*
(cdtf-alloc-bit-base! lsbs)))
(else
;; Narrow lsbs (small-width probe) OR direct-trunc-fast
;; off: keep V2's two-cadd path as the correctness floor.
(cadd-const! c v-reg lsbs c-const
ovf1 0 cin-reg cin-idx tmp-reg)
(cadd-const! c v-reg lsbs (* 2 c-const)
ovf2 0 cin-reg cin-idx tmp-reg)))
;; (7) Uncompute ovf1 via parity from v[0] = ovf1.
(gate-cx! c v-reg 0 ovf1 0)
;; (8) Uncompute ovf2 via parity from v[1] = ovf2 (guard above
;; ensures f[1] = 0 so no f[1]·ovf1 cross term).
(gate-cx! c v-reg 1 ovf2 0)
(free! c ovf2)
(free! c ovf1)))
;; Pseudo-Mersenne but f[1]=1 OR no headroom: fall back to V1
;; sequential pseudo-Mersenne folds (correct, no extra savings).
((and *mod-double-use-pseudo-mersenne*
(> c-const 0)
(< (+ padding f-bits) n+1))
(mod-double-inplace-pseudo-mersenne!
c v-reg n+1 p c-const cin-reg cin-idx tmp-reg flag-reg flag-idx)
(mod-double-inplace-pseudo-mersenne!
c v-reg n+1 p c-const cin-reg cin-idx tmp-reg flag-reg flag-idx))
;; General Solinas fallback: two mod-double-inplace! calls.
(else
(mod-double-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
(mod-double-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)))))))
;;; ── csub-2-controls-trunc-fast! — gate-level inverse of cadd-2-controls-trunc-fast! ─
;;;
;;; Drop-in mirror of `cadd-2-controls-trunc-fast!` (lines 1224-1325) where
;;; the per-position-controls truncated ripple uses `csub-per-position-
;;; controls-trunc!` instead of `cadd-per-position-controls-trunc!`. Derives
;;; the same 4 ancilla controls (h, xed, eord, n10) and uncomputes them in
;;; the exact-reverse order. Used by `mod-4x-inverse-inplace!` to gate-level
;;; invert HEAD's secp256k1-class pseudo-Mersenne 4x fold.
;;;
;;; Toffoli budget: identical to `cadd-2-controls-trunc-fast!` since
;;; csub-per-position-controls-trunc! emits the same 3-CCX-per-bit borrow
;;; sweep + HMR uncompute as the add variant. The 4 derived-ancilla setup +
;;; teardown is bit-for-bit shared with the forward call.
;;;
;;; Safety: identical bit-pattern guards as the forward variant — k2 must
;;; equal 2·k1 mod 2^lsbs AND k1 must carry HEAD's table bits {0,4,6,7,8,9,hi}.
;;; Errors otherwise. Caller responsible for picking a fresh `bit-base`
;;; window that does not collide with concurrent uses of the classical-bit
;;; lane (forward `cadd-2-controls-trunc-fast!` consumes
;;; [bit-base, bit-base + last] during its HMR uncompute pass).
(define (csub-2-controls-trunc-fast!
c acc-reg lsbs k1 ctrl1-reg ctrl1-idx k2 ctrl2-reg ctrl2-idx
tmp-reg window bit-base)
"acc[0..lsbs) -= (ctrl1 ? k1 : 0) + (ctrl2 ? k2 : 0) in ONE truncated
borrow sweep with per-position-controls. Hardcoded for HEAD's
secp256k1-class table where k2 == 2·k1 AND k1's bits sit at
{0,4,6,7,8,9,hi}. Gate-level inverse of cadd-2-controls-trunc-fast!.
*fold-freed-tail* routes through cadd-fold-ripple-freed-tail!
with is-add=#f (HEAD compressed.rs:3440 — same primitive serves
both add and sub fused folds)."
(cond
(*fold-freed-tail*
(let* ((kk1 (modulo k1 (expt 2 lsbs)))
(kk2 (modulo k2 (expt 2 lsbs))))
(cond
((= lsbs 0) #t)
((and (= kk1 0) (= kk2 0)) #t)
(else
(let ((hi (highest-set-bit kk1)))
(when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs))))
(error "csub-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)"
k1 k2 lsbs))
(when (not (and (bit-set? kk1 0) (bit-set? kk1 4)
(bit-set? kk1 6) (bit-set? kk1 7)
(bit-set? kk1 8) (bit-set? kk1 9)
(bit-set? kk1 hi)))
(error "csub-2-controls-trunc-fast!: k1 missing required bits"
k1 hi))
(when (<= lsbs (+ hi 1))
(error "csub-2-controls-trunc-fast!: lsbs <= hi+1, no room"
lsbs hi))
(let* ((last (min (- lsbs 2) (+ (+ hi 1) window)))
(hi-delta (+ hi 1)))
(when (<= last hi-delta)
(error "csub-2-controls-trunc-fast!: *fold-freed-tail* needs last > hi+1"
last hi-delta))
(cadd-fold-ripple-freed-tail!
c acc-reg lsbs
ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx
last hi hi-delta #f bit-base)))))))
(else
(let* ((kk1 (modulo k1 (expt 2 lsbs)))
(kk2 (modulo k2 (expt 2 lsbs))))
(cond
((= lsbs 0) #t)
((and (= kk1 0) (= kk2 0)) #t)
(else
(let ((hi (highest-set-bit kk1)))
(when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs))))
(error "csub-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)"
k1 k2 lsbs))
(when (not (and (bit-set? kk1 0)
(bit-set? kk1 4)
(bit-set? kk1 6)
(bit-set? kk1 7)
(bit-set? kk1 8)
(bit-set? kk1 9)
(bit-set? kk1 hi)))
(error "csub-2-controls-trunc-fast!: k1 missing required bits"
k1 hi))
(when (<= lsbs (+ hi 1))
(error "csub-2-controls-trunc-fast!: lsbs <= hi+1, no room"
lsbs hi))
;; Derive 4 ancilla controls — identical to forward path.
(let ((h '_v25r-h)
(xed '_v25r-xed)
(eord '_v25r-eord)
(n10 '_v25r-n10))
(alloc! c h 1)
(alloc! c xed 1)
(alloc! c eord 1)
(alloc! c n10 1)
;; h = ctrl1 & ctrl2
(gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
;; xed = ctrl1 ⊕ ctrl2
(gate-cx! c ctrl1-reg ctrl1-idx xed 0)
(gate-cx! c ctrl2-reg ctrl2-idx xed 0)
;; eord = xed ⊕ h
(gate-cx! c xed 0 eord 0)
(gate-cx! c h 0 eord 0)
;; n10 = ctrl2 ⊕ h
(gate-cx! c ctrl2-reg ctrl2-idx n10 0)
(gate-cx! c h 0 n10 0)
;; Issue the truncated borrow sweep with HEAD's per-position table.
(let* ((last (min (- lsbs 2)
(+ (+ hi 1) window)))
(controls (make-perpos-secp256k1-fold-controls
hi
(cons ctrl1-reg ctrl1-idx)
(cons ctrl2-reg ctrl2-idx)
(cons xed 0)
(cons eord 0)
(cons n10 0)
(cons h 0))))
(csub-per-position-controls-trunc!
c acc-reg lsbs controls last tmp-reg bit-base))
;; Uncompute derived ancilla in EXACT reverse — mirrors forward.
(gate-cx! c h 0 n10 0)
(gate-cx! c ctrl2-reg ctrl2-idx n10 0)
(gate-cx! c h 0 eord 0)
(gate-cx! c xed 0 eord 0)
(gate-cx! c ctrl2-reg ctrl2-idx xed 0)
(gate-cx! c ctrl1-reg ctrl1-idx xed 0)
(gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0)
(free! c n10)
(free! c eord)
(free! c xed)
(free! c h))))))))) ; closes (else ...) of *fold-freed-tail* dispatch
;;; ── mod-halve-inplace! — v := v * 2⁻¹ mod p, inverse of mod-double-inplace! ─
;;;
;;; Walk mod-double-inplace! steps in reverse with each step inverted.
;;; All 6 steps are self-inverse OR (add-const ↔ sub-const), (csub-const
;;; ↔ cadd-const). Used to walk hi back to its pre-Solinas state in
;;; Stage 2 of mod-mul-solinas!.
(define (mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
"Inverse of mod-double-inplace!: v := v * (2⁻¹ mod p)."
(let* ((n (- n+1 1))
(c-const (- (expt 2 n) p)))
;; (6') CX v[0] -> flag (self-inverse)
(gate-cx! c v-reg 0 flag-reg flag-idx)
;; (5') CX flag -> v[n] (self-inverse)
(gate-cx! c flag-reg flag-idx v-reg n)
;; (4') Reverse the X-csub-X sandwich. cadd-const replaces csub-const.
(gate-x! c flag-reg flag-idx)
(cadd-const! c v-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg)
(gate-x! c flag-reg flag-idx)
;; (3') CX v[n] -> flag (self-inverse)
(gate-cx! c v-reg n flag-reg flag-idx)
;; (2') sub-const c at width n+1 (inverse of add-const)
(sub-const! c v-reg n+1 c-const cin-reg cin-idx tmp-reg)
;; (1') Reverse the SWAP cascade. Walk from bottom up.
(let loop ((i 1))
(when (<= i n)
(gate-swap! c v-reg i v-reg (- i 1))
(loop (+ i 1))))))
;;; ── mod-4x-inverse-inplace! — v := v * 4⁻¹ mod p, gate-level inverse ─
;;; of mod-4x-inplace!
;;;
;;; HEAD reference: `compressed.rs:2283-2403` (`dialog_gcd_fused_halve_y`)
;;; — runs HEAD's apply-phase REVERSE pass during compressed-block
;;; decompression. Half of HEAD's headline -25k Toff/shot savings at
;;; iters=258 rides the reverse fold.
;;;
;;; Algorithm: walk `mod-4x-inplace!` (lines 3017-3122) in reverse with
;;; each step replaced by its gate-level inverse.
;;;
;;; Forward (V2.5 pseudo-Mersenne path):
;;; 1. alloc ovf1, ovf2
;;; 2. shift1 cascade (swap down: bit i ↔ bit i-1, i = n..1)
;;; 3. swap(v[n], ovf1)
;;; 4. shift2 cascade (swap down)
;;; 5. swap(v[n], ovf2)
;;; 6. cadd-2-controls-trunc-fast! (+ f·ovf1 + 2f·ovf2 single ripple)
;;; OR two cadd-const fallback (narrow-lsbs / direct-trunc-fast off)
;;; 7. cx v[0] → ovf1 (parity uncompute)
;;; 8. cx v[1] → ovf2 (parity uncompute)
;;; 9. free ovf2, ovf1
;;;
;;; Reverse:
;;; 1. alloc ovf1, ovf2 (both |0>)
;;; 2'. cx v[1] → ovf2 (self-inverse — re-encode parity)
;;; 3'. cx v[0] → ovf1 (self-inverse — re-encode parity)
;;; 4'. csub-2-controls-trunc-fast! (inverse of 6 forward)
;;; OR two csub-const fallback
;;; 5'. swap(v[n], ovf2) (self-inverse)
;;; 6'. shift2 cascade reversed (swap UP: bit i-1 ↔ bit i, i = 1..n)
;;; 7'. swap(v[n], ovf1) (self-inverse)
;;; 8'. shift1 cascade reversed (swap up)
;;; 9'. free ovf2, ovf1
;;;
;;; The shift cascades use `gate-swap!` which is self-inverse, so reversing
;;; the loop direction inverts the cascade.
;;;
;;; Each cadd ↔ csub pair has identical Toffoli budget — the reverse fold
;;; emits the SAME -58 Toff/call savings vs the V1 sequential `mod-halve`
;;; equivalent. ~50 % shift2-density × iters=258 ≈ 129 calls/shot →
;;; -7-8k Toff/shot when the reverse-fusion has a callsite. Combined
;;; with forward fusion: HEAD's headline -25k Toff/shot.
;;;
;;; CALLSITE NOTE: lumbda's `mod-inv-by-dialog-gcd-host!` backward sweep
;;; (line 595) runs CLASSICAL-REPLAY via `classical-reset!`, not a
;;; gate-level reverse iter walk. The reverse-fusion primitive ships now
;;; so a future sweep that adds a gate-level reverse iter (Option A,
;;; multi-day) has the apply-phase reverse-fold ready. See
;;; SWEEP-NOTES.md for the substrate gap analysis.
;;;
;;; Safety: identical guards to `mod-4x-inplace!`. Errors when
;;; *dgcd-k2-bounded-shift* off (semantics meaningless outside K=2 trace).
(define (mod-4x-inverse-inplace! c v-reg n+1 p
cin-reg cin-idx tmp-reg flag-reg flag-idx)
"v-reg := v-reg * (4⁻¹ mod p) (in place). v-reg is (n+1)-wide; v stored
in low n bits, bit n starts |0> and ends |0>. Same scratch suite as
mod-4x-inplace!.
When *mod-double-use-pseudo-mersenne* is #t AND p is a pseudo-Mersenne
prime AND f[1] = 0, walks the V2 inlined dual-shift + ovf-capture path
in reverse using csub-const (or csub-2-controls-trunc-fast! when
*cadd-direct-trunc-fast* on). Otherwise falls back to two
mod-halve-inplace! calls (general Solinas path).
Defensive guard: errors when *dgcd-k2-bounded-shift* is off."
(cond
((not *dgcd-k2-bounded-shift*)
(error "mod-4x-inverse-inplace! requires *dgcd-k2-bounded-shift* #t"))
(else
(let* ((n (- n+1 1))
(c-const (- (expt 2 n) p))
(f-bits (pmersenne-bit-length c-const))
(padding *mod-double-pseudo-mersenne-padding*)
(lsbs (min n+1 (+ padding f-bits))))
(cond
;; ── V2-reverse: pseudo-Mersenne dual-shift + ovf-capture inverse ──
((and *mod-double-use-pseudo-mersenne*
(> c-const 0)
(< (+ padding f-bits) n+1)
(not (bit-set? c-const 1)))
(let ((ovf1 '_4xr-ovf1)
(ovf2 '_4xr-ovf2))
(alloc! c ovf1 1)
(alloc! c ovf2 1)
;; (8') CX v[1] -> ovf2 (self-inverse — re-encode ovf2 parity).
(gate-cx! c v-reg 1 ovf2 0)
;; (7') CX v[0] -> ovf1 (self-inverse — re-encode ovf1 parity).
(gate-cx! c v-reg 0 ovf1 0)
;; (5+6') Inverse fused fold: v[0..lsbs) -= f·ovf1 + 2f·ovf2.
(cond
((and (> lsbs (+ (highest-set-bit c-const) 2))
*cadd-direct-trunc-fast*)
;; H7a peel-8 fix: cdtf-alloc-bit-base! gives this call a
;; fresh non-overlapping slot range, so the prior `(+ base
;; (* 8 n+1))` hand-offset to dodge forward/reverse HMR
;; collision is no longer required.
(csub-2-controls-trunc-fast!
c v-reg lsbs
c-const ovf1 0
(* 2 c-const) ovf2 0
tmp-reg
*cadd-direct-window*
(cdtf-alloc-bit-base! lsbs)))
(else
;; Narrow lsbs OR direct-trunc-fast off: invert via two
;; csub-const calls in reverse order (matches V2 fallback
;; pair `cadd-const(c,ovf1)` + `cadd-const(2c,ovf2)`).
(csub-const! c v-reg lsbs (* 2 c-const)
ovf2 0 cin-reg cin-idx tmp-reg)
(csub-const! c v-reg lsbs c-const
ovf1 0 cin-reg cin-idx tmp-reg)))
;; (4') swap(v[n], ovf2) — self-inverse (re-injects v_orig[n-2]).
(gate-swap! c v-reg n ovf2 0)
;; (3') Reverse shift2 swap cascade. Forward walked i = n..1
;; with gate-swap(v[i], v[i-1]); reverse walks i = 1..n.
(let loop ((i 1))
(when (<= i n)
(gate-swap! c v-reg i v-reg (- i 1))
(loop (+ i 1))))
;; (2') swap(v[n], ovf1) — self-inverse (re-injects v_orig[n-1]).
(gate-swap! c v-reg n ovf1 0)
;; (1') Reverse shift1 swap cascade.
(let loop ((i 1))
(when (<= i n)
(gate-swap! c v-reg i v-reg (- i 1))
(loop (+ i 1))))
(free! c ovf2)
(free! c ovf1)))
;; Pseudo-Mersenne but f[1]=1 OR no headroom: invert via V1
;; sequential pseudo-Mersenne halves (two mod-halve passes).
((and *mod-double-use-pseudo-mersenne*
(> c-const 0)
(< (+ padding f-bits) n+1))
(mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
(mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx))
;; General Solinas fallback: two mod-halve-inplace! calls.
(else
(mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)
(mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)))))))
Reference in a new issue View git blame Copy permalink