russell@unturf.com
1665893321
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.
595 lines
29 KiB
Text
595 lines
29 KiB
Text
;;; mod-solinas.lsp — Phase B step 7: Solinas-style fast reduction
|
||
;;; for mod-mul, primes of form p = 2^n - c with sparse c.
|
||
;;;
|
||
;;; Cuts mod-mul Stage 2 from O(n²) (2n bit-loops × O(n) mod-add per bit)
|
||
;;; to O(popcount(c) × n) — a small constant × n. For our test primes
|
||
;;; c = 5 = 2² + 2⁰ → popcount=2 → 2 mod-adds + 2 mod-doubles ≈ 4 cuccaro
|
||
;;; operations instead of 2n. Speedup at n=8 (p=251): ~16× fewer cuccaros.
|
||
;;;
|
||
;;; Mirrors upstream `mod_mul_write_into_zero_acc_schoolbook` at
|
||
;;; ~/git/ecdsafail-challenge/src/point_add/mod.rs:4044 — the same pattern
|
||
;;; of walking hi through doublings and folding ±-add into acc keyed on
|
||
;;; the bits of c.
|
||
;;;
|
||
;;; Math:
|
||
;;; x*y splits as [lo | hi] where lo = bits[0..n), hi = bits[n..2n).
|
||
;;; Then x*y = hi*2^n + lo. Since p = 2^n - c, 2^n ≡ c (mod p).
|
||
;;; So (x*y) mod p = (lo + c*hi) mod p.
|
||
;;; With c = Σ sign·2^k_j, this becomes lo + Σ sign·(hi · 2^k_j) mod p.
|
||
;;;
|
||
;;; Calling convention (same shape as mod-mul!):
|
||
;;; a-reg, b-reg, out-reg : (n+1)-wide; top bit |0>.
|
||
;;; c-expansion : Scheme list of (sign . shift) pairs encoding
|
||
;;; c = Σ sign · 2^shift. Caller computes once.
|
||
;;; e.g. for p=11/p=251 (c=5):
|
||
;;; '((1 . 2) (1 . 0))
|
||
;;; Pairs must be sorted by ASCENDING shift
|
||
;;; because we cumulatively double hi.
|
||
;;; cin, tmp, flag, red-tmp : same scratch suite as mod-mul!.
|
||
;;;
|
||
;;; Internal ancillae (Litinski + Solinas):
|
||
;;; sb-tmp-ext (2n bits) wide product accumulator (Stage 1 / 3)
|
||
;;; sb-low (1 bit) wide[0] for Stage 1 / 3
|
||
;;; sb-xext (n+1 bits) Stage 1 / 3 add-subtract scratch
|
||
;;; sb-const-tmp (n+1 bits) Stage 1 / 3 constant-loading scratch
|
||
;;; sol-lo-ext (n+1 bits) Stage-2 lo-as-extended-reg copy
|
||
;;; sol-hi-ext (n+1 bits) Stage-2 hi-as-extended-reg copy (walks via doublings)
|
||
|
||
(load "quantum/gates.lsp")
|
||
(load "quantum/adder.lsp")
|
||
(load "quantum/mod-arith.lsp")
|
||
|
||
;;; ── from-zero specialization lever ────────────────────────────────
|
||
;;;
|
||
;;; *mod-mul-from-zero-first-add* — when #t, mod-mul-solinas-from-zero!
|
||
;;; (& its callers) replace Stage 2a's first mod-add! with
|
||
;;; mod-add-from-zero!. Saves n CCX per fresh-multiply call. Caller
|
||
;;; opts in by invoking mod-mul-from-zero! (mod-arith.lsp) instead of
|
||
;;; mod-mul!. Default OFF so opt-out is trivial.
|
||
;;;
|
||
;;; Port of HEAD's `mod_add_qq_fast_from_zero` specialization
|
||
;;; (mod.rs:961-1038) lifted to the Solinas Stage 2 entry point.
|
||
|
||
(define *mod-mul-from-zero-first-add* #f)
|
||
|
||
;;; ── helper: apply n consecutive doublings to a register ──
|
||
|
||
(define (mod-double-n! c v-reg n+1 p k
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
"Apply mod-double-inplace! k times. v := v * 2^k mod p. k >= 0."
|
||
(let loop ((i 0))
|
||
(when (< i k)
|
||
(mod-double-inplace! c v-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
(loop (+ i 1)))))
|
||
|
||
(define (mod-halve-n! c v-reg n+1 p k
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
"Apply mod-halve-inplace! k times. v := v * 2^(-k) mod p."
|
||
(let loop ((i 0))
|
||
(when (< i k)
|
||
(mod-halve-inplace! c v-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
(loop (+ i 1)))))
|
||
|
||
;;; ── helper: CX-copy a slice of one register into the low bits of another ──
|
||
|
||
(define (cx-copy-slice! c src-reg src-off tgt-reg width)
|
||
"tgt[k] ^= src[src-off + k] for k in [0, width). Self-inverse."
|
||
(let loop ((k 0))
|
||
(when (< k width)
|
||
(gate-cx! c src-reg (+ src-off k) tgt-reg k)
|
||
(loop (+ k 1)))))
|
||
|
||
;;; ── mod-mul-solinas! — Litinski schoolbook + Solinas Stage-2 reduce ──
|
||
|
||
(define (mod-mul-solinas! c a-reg b-reg out-reg n+1 p c-expansion
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx
|
||
red-tmp-reg)
|
||
"out := (a * b) mod p using Solinas fast reduction.
|
||
c-expansion encodes c = 2^n - p as ((sign . shift) ...) sorted by
|
||
ASCENDING shift. See file header for full calling convention.
|
||
red-tmp-reg unused here (kept for signature parity with mod-mul!);
|
||
may be passed as any (n+1)-wide ancilla |0> in/out (caller still
|
||
allocs to keep the call site uniform with mod-mul!)."
|
||
(let ((n (- n+1 1)))
|
||
(cond
|
||
((= n 0) #t)
|
||
(else
|
||
;; ── Stage 0: alloc Litinski scratch ──
|
||
;;
|
||
;; sweep-036: when *sub-x-from-wide-host-alloc* is on, hoist
|
||
;; sb-xfull alloc to OUTERMOST Stage-0 step so it lands at the
|
||
;; lowest free 513-wide base inside the mod-mul scope. Width
|
||
;; matches sub-x-from-wide!'s internal compute:
|
||
;; xfull-width = 2n+1 by default
|
||
;; = 4n+1 when *cuccaro-callers-fast* AND
|
||
;; *sub-x-from-wide-cas-fast* both on.
|
||
;; *host-sb-xfull-reg* communicates the name to sub-x-from-wide!
|
||
;; & add-x-into-wide! (mod-arith.lsp) without changing their
|
||
;; signatures.
|
||
(when *sub-x-from-wide-host-alloc*
|
||
(let* ((use-fast? (and *cuccaro-callers-fast*
|
||
*sub-x-from-wide-cas-fast*))
|
||
(joint-width (+ (* 2 n) 1))
|
||
(xfull-width (cond (use-fast? (+ joint-width
|
||
(- joint-width 1)))
|
||
(else joint-width))))
|
||
(alloc! c (quote sb-xfull-host) xfull-width)
|
||
(set! *host-sb-xfull-reg* (quote sb-xfull-host))))
|
||
(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))
|
||
;; Optional CAS-borrowed carries register for HMR dispatch in
|
||
;; cuccaro-add-offset! (mod-arith.lsp). Activated by setting
|
||
;; *cuccaro-callers-fast* #t at emit driver level. Borrows from
|
||
;; red-tmp-reg (caller-passed, unused per Solinas signature
|
||
;; convention — see file header). ZERO qubit cost.
|
||
(when *cuccaro-callers-fast*
|
||
(set! *cas-borrowed-carries-reg* red-tmp-reg)
|
||
(set! *cas-borrowed-carries-offset* 0)
|
||
(set! *cas-borrowed-bit-base* 200000)
|
||
;; red-tmp-reg is (n+1) wide; fast-borrowed dispatch consumes
|
||
;; (width-1) carries lanes. Set width=n+1 so joint dispatch
|
||
;; falls through for sub-x-from-wide (width 2n+1, needs 2n
|
||
;; slots) — only schoolbook-row-k0 (width n+1, needs n slots)
|
||
;; activates. Offset variants (width n+1) always fit.
|
||
(set! *cas-borrowed-carries-width* (+ 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 via Solinas walk ──
|
||
;; 2a. out += lo mod p
|
||
;; 2b. for each (sign . shift) in c-expansion (ascending):
|
||
;; advance hi by delta-shift doublings; out += sign * hi mod p
|
||
;; 2c. walk hi all the way back via halvings to clear the copy.
|
||
;;
|
||
;; alg-11 mirror — classical Stage-2 tracker. When both a-reg and
|
||
;; b-reg carry classical values (find-classical-value via
|
||
;; bind-input!/rebind-mirror! channel), derive the classical
|
||
;; product & track lo / hi / out across the Stage-2 walk so the
|
||
;; in-line mod-add!/mod-sub!/mod-double-n! dispatchers can
|
||
;; route pseudo-Mersenne on safe inputs.
|
||
(let* ((a-cl (find-classical-value c a-reg))
|
||
(b-cl (find-classical-value c b-reg))
|
||
(out-cl (find-classical-value c out-reg))
|
||
(track? (and a-cl b-cl out-cl))
|
||
(prod (and track? (* a-cl b-cl)))
|
||
(lo-cl (and track? (modulo prod (expt 2 n))))
|
||
(hi-cl (and track? (quotient prod (expt 2 n)))))
|
||
;; sol-lo-ext (n+1) holds a CX-copy of sb-tmp-ext[0..n) in low n
|
||
;; bits; top bit stays |0>.
|
||
(alloc! c (quote sol-lo-ext) (+ n 1))
|
||
(cx-copy-slice! c (quote sb-tmp-ext) 0 (quote sol-lo-ext) n)
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-lo-ext) lo-cl))
|
||
(mod-add! c (quote sol-lo-ext) out-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
(when track?
|
||
(rebind-mirror! c out-reg (modulo (+ out-cl lo-cl) p)))
|
||
(cx-copy-slice! c (quote sb-tmp-ext) 0 (quote sol-lo-ext) n)
|
||
(free! c (quote sol-lo-ext))
|
||
;; sol-hi-ext: copy of sb-tmp-ext[n..2n) in low n bits.
|
||
(alloc! c (quote sol-hi-ext) (+ n 1))
|
||
(cx-copy-slice! c (quote sb-tmp-ext) n (quote sol-hi-ext) n)
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-hi-ext) hi-cl))
|
||
;; Walk hi via mod-doublings. Track cumulative shift via current-shift.
|
||
(let loop ((rest c-expansion)
|
||
(current-shift 0)
|
||
(cur-hi (and track? hi-cl))
|
||
(cur-out (and track? (modulo (+ out-cl lo-cl) p))))
|
||
(cond
|
||
((null? rest)
|
||
;; Walk hi back to its original value via halvings.
|
||
(mod-halve-n! c (quote sol-hi-ext) n+1 p current-shift
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-hi-ext) hi-cl)))
|
||
(else
|
||
(let* ((pair (car rest))
|
||
(sign (car pair))
|
||
(shift (cdr pair))
|
||
(delta (- shift current-shift)))
|
||
(when (< delta 0)
|
||
(error "mod-mul-solinas: c-expansion must be ascending"
|
||
(list current-shift shift)))
|
||
(mod-double-n! c (quote sol-hi-ext) n+1 p delta
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
(let* ((hi-after (and track?
|
||
(modulo (* cur-hi (expt 2 delta)) p)))
|
||
(next-out (cond
|
||
((not track?) #f)
|
||
((= sign 1)
|
||
(modulo (+ cur-out hi-after) p))
|
||
(else
|
||
(modulo (- cur-out hi-after) p)))))
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-hi-ext) hi-after))
|
||
(cond
|
||
((= sign 1)
|
||
(mod-add! c (quote sol-hi-ext) out-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx))
|
||
((= sign -1)
|
||
(mod-sub! c (quote sol-hi-ext) out-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx))
|
||
(else
|
||
(error "mod-mul-solinas: sign must be ±1" sign)))
|
||
(when track?
|
||
(rebind-mirror! c out-reg next-out))
|
||
(loop (cdr rest) shift hi-after next-out)))))))
|
||
;; Uncopy hi from sb-tmp-ext.
|
||
(cx-copy-slice! c (quote sb-tmp-ext) n (quote sol-hi-ext) n)
|
||
(free! c (quote sol-hi-ext))
|
||
;; ── 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 ──
|
||
(when *cuccaro-callers-fast*
|
||
(set! *cas-borrowed-carries-reg* #f))
|
||
(free! c (quote sb-const-tmp))
|
||
(free! c (quote sb-xext))
|
||
(free! c (quote sb-low))
|
||
(free! c (quote sb-tmp-ext))
|
||
;; sweep-036: free host-allocated sb-xfull (if hoisted).
|
||
(when *sub-x-from-wide-host-alloc*
|
||
(set! *host-sb-xfull-reg* #f)
|
||
(free! c (quote sb-xfull-host)))))))
|
||
|
||
;;; ── mod-mul-solinas-sub! — out := out - (a*b) mod p via Solinas ──
|
||
;;;
|
||
;;; Mirror of mod-mul-sub! using Solinas Stage 2. Needed so we can swap
|
||
;;; in mod-mul-solinas! through the Roetteler point-add (which calls
|
||
;;; mod-mul-sub! at steps 5, 10, 12c, 12d).
|
||
|
||
(define (mod-mul-solinas-sub! c a-reg b-reg out-reg n+1 p c-expansion
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx
|
||
red-tmp-reg)
|
||
"out := (out - a*b) mod p via Solinas. Mirror of mod-mul-solinas! with
|
||
sign-inverted Stage-2 mod-add/mod-sub."
|
||
(let ((n (- n+1 1)))
|
||
(cond
|
||
((= n 0) #t)
|
||
(else
|
||
;; sweep-036: hoist sb-xfull alloc when opt-in flag is set.
|
||
(when *sub-x-from-wide-host-alloc*
|
||
(let* ((use-fast? (and *cuccaro-callers-fast*
|
||
*sub-x-from-wide-cas-fast*))
|
||
(joint-width (+ (* 2 n) 1))
|
||
(xfull-width (cond (use-fast? (+ joint-width
|
||
(- joint-width 1)))
|
||
(else joint-width))))
|
||
(alloc! c (quote sb-xfull-host) xfull-width)
|
||
(set! *host-sb-xfull-reg* (quote sb-xfull-host))))
|
||
(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))
|
||
(when *cuccaro-callers-fast*
|
||
(set! *cas-borrowed-carries-reg* red-tmp-reg)
|
||
(set! *cas-borrowed-carries-offset* 0)
|
||
(set! *cas-borrowed-bit-base* 200000)
|
||
;; red-tmp-reg is (n+1) wide; fast-borrowed dispatch consumes
|
||
;; (width-1) carries lanes. Set width=n+1 so joint dispatch
|
||
;; falls through for sub-x-from-wide (width 2n+1, needs 2n
|
||
;; slots) — only schoolbook-row-k0 (width n+1, needs n slots)
|
||
;; activates. Offset variants (width n+1) always fit.
|
||
(set! *cas-borrowed-carries-width* (+ n 1)))
|
||
(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 with SIGN INVERTED on every fold (mod-add ↔ mod-sub).
|
||
;; alg-11 classical-mirror tracker — same shape as mod-mul-solinas!
|
||
;; but sign is flipped for the running out accumulator.
|
||
(let* ((a-cl (find-classical-value c a-reg))
|
||
(b-cl (find-classical-value c b-reg))
|
||
(out-cl (find-classical-value c out-reg))
|
||
(track? (and a-cl b-cl out-cl))
|
||
(prod (and track? (* a-cl b-cl)))
|
||
(lo-cl (and track? (modulo prod (expt 2 n))))
|
||
(hi-cl (and track? (quotient prod (expt 2 n)))))
|
||
(alloc! c (quote sol-lo-ext) (+ n 1))
|
||
(cx-copy-slice! c (quote sb-tmp-ext) 0 (quote sol-lo-ext) n)
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-lo-ext) lo-cl))
|
||
(mod-sub! c (quote sol-lo-ext) out-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
(when track?
|
||
(rebind-mirror! c out-reg (modulo (- out-cl lo-cl) p)))
|
||
(cx-copy-slice! c (quote sb-tmp-ext) 0 (quote sol-lo-ext) n)
|
||
(free! c (quote sol-lo-ext))
|
||
(alloc! c (quote sol-hi-ext) (+ n 1))
|
||
(cx-copy-slice! c (quote sb-tmp-ext) n (quote sol-hi-ext) n)
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-hi-ext) hi-cl))
|
||
(let loop ((rest c-expansion)
|
||
(current-shift 0)
|
||
(cur-hi (and track? hi-cl))
|
||
(cur-out (and track? (modulo (- out-cl lo-cl) p))))
|
||
(cond
|
||
((null? rest)
|
||
(mod-halve-n! c (quote sol-hi-ext) n+1 p current-shift
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-hi-ext) hi-cl)))
|
||
(else
|
||
(let* ((pair (car rest))
|
||
(sign (car pair))
|
||
(shift (cdr pair))
|
||
(delta (- shift current-shift)))
|
||
(when (< delta 0)
|
||
(error "mod-mul-solinas-sub: c-expansion must be ascending"
|
||
(list current-shift shift)))
|
||
(mod-double-n! c (quote sol-hi-ext) n+1 p delta
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
(let* ((hi-after (and track?
|
||
(modulo (* cur-hi (expt 2 delta)) p)))
|
||
(next-out (cond
|
||
((not track?) #f)
|
||
((= sign 1)
|
||
(modulo (- cur-out hi-after) p))
|
||
(else
|
||
(modulo (+ cur-out hi-after) p)))))
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-hi-ext) hi-after))
|
||
(cond
|
||
((= sign 1)
|
||
(mod-sub! c (quote sol-hi-ext) out-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx))
|
||
((= sign -1)
|
||
(mod-add! c (quote sol-hi-ext) out-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx))
|
||
(else
|
||
(error "mod-mul-solinas-sub: sign must be ±1" sign)))
|
||
(when track?
|
||
(rebind-mirror! c out-reg next-out))
|
||
(loop (cdr rest) shift hi-after next-out)))))))
|
||
(cx-copy-slice! c (quote sb-tmp-ext) n (quote sol-hi-ext) n)
|
||
(free! c (quote sol-hi-ext))
|
||
(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))
|
||
(when *cuccaro-callers-fast*
|
||
(set! *cas-borrowed-carries-reg* #f))
|
||
(free! c (quote sb-const-tmp))
|
||
(free! c (quote sb-xext))
|
||
(free! c (quote sb-low))
|
||
(free! c (quote sb-tmp-ext))
|
||
;; sweep-036: free host-allocated sb-xfull (if hoisted).
|
||
(when *sub-x-from-wide-host-alloc*
|
||
(set! *host-sb-xfull-reg* #f)
|
||
(free! c (quote sb-xfull-host)))))))
|
||
|
||
;;; ── mod-mul-solinas-from-zero! — out=|0> specialization ──────────
|
||
;;;
|
||
;;; Caller-explicit specialization of mod-mul-solinas! for the case
|
||
;;; where out-reg is guaranteed to be |0> on entry. Mirror of
|
||
;;; mod-mul-solinas! verbatim except Stage 2a's mod-add! swaps to
|
||
;;; mod-add-from-zero! — saves n CCX per call.
|
||
;;;
|
||
;;; Caller responsibility: out-reg MUST be |0> across all n+1 bits on
|
||
;;; entry. Typical sites: mod-square! (out alloc'd same line) and
|
||
;;; mod-inv-by Fermat ladder's r-next / b-next freshly-alloc'd registers.
|
||
;;;
|
||
;;; Port mirrors HEAD's `mod_add_qq_fast_from_zero` (mod.rs:961-1038)
|
||
;;; lifted to the Solinas Stage 2 entry boundary. Stage 2b+ uses plain
|
||
;;; mod-add! / mod-sub! because out-reg is no longer zero after 2a.
|
||
|
||
(define (mod-mul-solinas-from-zero! c a-reg b-reg out-reg n+1 p c-expansion
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx
|
||
red-tmp-reg)
|
||
"out := (a * b) mod p assuming out is |0> on entry. Same calling
|
||
convention as mod-mul-solinas!; Stage 2a uses mod-add-from-zero!
|
||
for n CCX savings vs mod-mul-solinas!."
|
||
(let ((n (- n+1 1)))
|
||
(cond
|
||
((= n 0) #t)
|
||
(else
|
||
;; ── Stage 0: alloc Litinski scratch (same as mod-mul-solinas!) ──
|
||
(when *sub-x-from-wide-host-alloc*
|
||
(let* ((use-fast? (and *cuccaro-callers-fast*
|
||
*sub-x-from-wide-cas-fast*))
|
||
(joint-width (+ (* 2 n) 1))
|
||
(xfull-width (cond (use-fast? (+ joint-width
|
||
(- joint-width 1)))
|
||
(else joint-width))))
|
||
(alloc! c (quote sb-xfull-host) xfull-width)
|
||
(set! *host-sb-xfull-reg* (quote sb-xfull-host))))
|
||
(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))
|
||
(when *cuccaro-callers-fast*
|
||
(set! *cas-borrowed-carries-reg* red-tmp-reg)
|
||
(set! *cas-borrowed-carries-offset* 0)
|
||
(set! *cas-borrowed-bit-base* 200000)
|
||
(set! *cas-borrowed-carries-width* (+ n 1)))
|
||
;; ── Stage 1: wide product (unchanged) ──
|
||
(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 2a: out += lo mod p — FROM-ZERO PATH ──
|
||
;; alg-11 classical-mirror tracker — same shape as mod-mul-solinas!
|
||
;; but out starts at 0 per the from-zero contract.
|
||
(let* ((a-cl (find-classical-value c a-reg))
|
||
(b-cl (find-classical-value c b-reg))
|
||
(track? (and a-cl b-cl))
|
||
(prod (and track? (* a-cl b-cl)))
|
||
(lo-cl (and track? (modulo prod (expt 2 n))))
|
||
(hi-cl (and track? (quotient prod (expt 2 n)))))
|
||
(alloc! c (quote sol-lo-ext) (+ n 1))
|
||
(cx-copy-slice! c (quote sb-tmp-ext) 0 (quote sol-lo-ext) n)
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-lo-ext) lo-cl))
|
||
(cond
|
||
(*mod-mul-from-zero-first-add*
|
||
(mod-add-from-zero! c (quote sol-lo-ext) out-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx))
|
||
(else
|
||
(mod-add! c (quote sol-lo-ext) out-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)))
|
||
(when track?
|
||
(rebind-mirror! c out-reg (modulo lo-cl p)))
|
||
(cx-copy-slice! c (quote sb-tmp-ext) 0 (quote sol-lo-ext) n)
|
||
(free! c (quote sol-lo-ext))
|
||
;; ── Stage 2b+: out is no longer zero — use plain mod-add!. ──
|
||
(alloc! c (quote sol-hi-ext) (+ n 1))
|
||
(cx-copy-slice! c (quote sb-tmp-ext) n (quote sol-hi-ext) n)
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-hi-ext) hi-cl))
|
||
(let loop ((rest c-expansion)
|
||
(current-shift 0)
|
||
(cur-hi (and track? hi-cl))
|
||
(cur-out (and track? (modulo lo-cl p))))
|
||
(cond
|
||
((null? rest)
|
||
(mod-halve-n! c (quote sol-hi-ext) n+1 p current-shift
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-hi-ext) hi-cl)))
|
||
(else
|
||
(let* ((pair (car rest))
|
||
(sign (car pair))
|
||
(shift (cdr pair))
|
||
(delta (- shift current-shift)))
|
||
(when (< delta 0)
|
||
(error "mod-mul-solinas-from-zero: c-expansion must be ascending"
|
||
(list current-shift shift)))
|
||
(mod-double-n! c (quote sol-hi-ext) n+1 p delta
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx)
|
||
(let* ((hi-after (and track?
|
||
(modulo (* cur-hi (expt 2 delta)) p)))
|
||
(next-out (cond
|
||
((not track?) #f)
|
||
((= sign 1)
|
||
(modulo (+ cur-out hi-after) p))
|
||
(else
|
||
(modulo (- cur-out hi-after) p)))))
|
||
(when track?
|
||
(rebind-mirror! c (quote sol-hi-ext) hi-after))
|
||
(cond
|
||
((= sign 1)
|
||
(mod-add! c (quote sol-hi-ext) out-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx))
|
||
((= sign -1)
|
||
(mod-sub! c (quote sol-hi-ext) out-reg n+1 p
|
||
cin-reg cin-idx tmp-reg flag-reg flag-idx))
|
||
(else
|
||
(error "mod-mul-solinas-from-zero: sign must be ±1" sign)))
|
||
(when track?
|
||
(rebind-mirror! c out-reg next-out))
|
||
(loop (cdr rest) shift hi-after next-out)))))))
|
||
(cx-copy-slice! c (quote sb-tmp-ext) n (quote sol-hi-ext) n)
|
||
(free! c (quote sol-hi-ext))
|
||
;; ── Stage 3: uncompute wide product (unchanged) ──
|
||
(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 scratch (unchanged) ──
|
||
(when *cuccaro-callers-fast*
|
||
(set! *cas-borrowed-carries-reg* #f))
|
||
(free! c (quote sb-const-tmp))
|
||
(free! c (quote sb-xext))
|
||
(free! c (quote sb-low))
|
||
(free! c (quote sb-tmp-ext))
|
||
(when *sub-x-from-wide-host-alloc*
|
||
(set! *host-sb-xfull-reg* #f)
|
||
(free! c (quote sb-xfull-host)))))))
|
||
|
||
;;; ── classical helper: compute c-expansion for p = 2^n - c ──
|
||
;;;
|
||
;;; Returns ((1 . k0) (1 . k1) ...) for c = Σ 2^k_i (i.e. naive bit-set
|
||
;;; expansion, sorted by ascending shift). For sparse c with consecutive
|
||
;;; runs the *solinas-c-naf* lever (sweep-092) emits NAF ±1 expansion
|
||
;;; which drops popcount on runs (e.g. secp256k1 c = 2^32 + 977 goes
|
||
;;; 7 -> 5 terms; saves 2 mod-add/sub + 2 mod-double-n calls per
|
||
;;; mod-mul-solinas! invocation).
|
||
|
||
;;; *solinas-c-naf* — sweep-092 lever. Port of HEAD's R84_QPROD_NAF
|
||
;;; rewrite of the round84 quotient * c product. HEAD ed94ad2
|
||
;;; (2026-06-09 13:43 UTC). When #t, compute-c-expansion emits the
|
||
;;; non-adjacent-form (NAF) ±1 expansion of c instead of the naive
|
||
;;; bit-set expansion. Both Stage-2 loops in mod-mul-solinas! /
|
||
;;; -sub! / -from-zero! already handle (sign . shift) pairs with
|
||
;;; sign in {+1, -1}, so this is purely a classical-helper change.
|
||
;;;
|
||
;;; NAF properties: any integer has a unique NAF with no two
|
||
;;; consecutive non-zero digits. For runs of consecutive 1 bits
|
||
;;; like 977 = 0b1111010001 the NAF replaces a run length L with
|
||
;;; 2 terms (one -1 at the run's low end, one +1 at the next zero
|
||
;;; above the run). For secp256k1's c = 2^32 + 977:
|
||
;;; naive: (1.0) (1.4) (1.6) (1.7) (1.8) (1.9) (1.32) ; 7 terms
|
||
;;; NAF : (1.0) (1.4) (-1.6) (1.10) (1.32) ; 5 terms
|
||
;;;
|
||
;;; Default #f preserves naive byte-identity (HEAD's pre-ed94ad2 form).
|
||
;;; When #t adds the cost of one NAF computation per Solinas mod-mul
|
||
;;; (constant time on n+1 = 257; negligible vs the circuit emit cost).
|
||
|
||
(define *solinas-c-naf* #f)
|
||
|
||
(define (compute-c-expansion-naive p n)
|
||
"Naive bit-set expansion (pre-sweep-092 form)."
|
||
(let ((c-val (- (expt 2 n) p)))
|
||
(when (<= c-val 0)
|
||
(error "compute-c-expansion-naive: p must satisfy p < 2^n" (list p n)))
|
||
(let loop ((i 0) (acc (quote ())))
|
||
(cond
|
||
((>= i n)
|
||
(reverse acc))
|
||
((bit-set? c-val i)
|
||
(loop (+ i 1) (cons (cons 1 i) acc)))
|
||
(else
|
||
(loop (+ i 1) acc))))))
|
||
|
||
(define (compute-c-expansion-naf p n)
|
||
"NAF (non-adjacent form) ±1 expansion of c = 2^n - p. Returns a
|
||
list of (sign . shift) pairs sorted by ascending shift, with
|
||
sign in {+1, -1}. NAF guarantees no two consecutive shifts share
|
||
a non-zero digit, so over runs of consecutive 1-bits the
|
||
popcount drops from L to 2."
|
||
(let ((c-val (- (expt 2 n) p)))
|
||
(when (<= c-val 0)
|
||
(error "compute-c-expansion-naf: p must satisfy p < 2^n" (list p n)))
|
||
;; Standard NAF: while c > 0, if c odd then z = 2 - (c mod 4),
|
||
;; subtract z from c, else z = 0; emit z at current shift; c >>= 1.
|
||
;; We use quotient (not arithmetic-shift) for C-tier compatibility.
|
||
(let loop ((c c-val) (i 0) (acc (quote ())))
|
||
(cond
|
||
((= c 0)
|
||
(reverse acc))
|
||
((= (remainder c 2) 1)
|
||
(let ((z (- 2 (remainder c 4))))
|
||
(loop (quotient (- c z) 2) (+ i 1)
|
||
(cons (cons z i) acc))))
|
||
(else
|
||
(loop (quotient c 2) (+ i 1) acc))))))
|
||
|
||
(define (compute-c-expansion p n)
|
||
"Compute the c = 2^n - p expansion as an ascending list of
|
||
(sign . shift) pairs. Caller can pre-compute and pass into
|
||
mod-mul-solinas!. When *solinas-c-naf* is #t emits the NAF
|
||
±1 form (sweep-092); else emits the naive +1 bit-set form."
|
||
(cond
|
||
(*solinas-c-naf* (compute-c-expansion-naf p n))
|
||
(else (compute-c-expansion-naive p n))))
|