;;; 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))))