lumbda/quantum/gates.lsp

;;; gates.lsp — Reversible gate primitives, emit S-expression circuit stream.
;;;
;;; A circuit builder accumulates a list of ops. emit-circuit walks our
;;; builder into a tagged S-expression that any portal reader (sim.lsp on
;;; any tier, a future asm reader, a Rust codegen step) can consume.
;;;
;;; Wire format (`portals/circuit.portal`):
;;;
;;;   (circuit
;;;     (version 1)
;;;     (curve <name>)
;;;     (registers (<name> <width>) ...)
;;;     (input (<name> <integer>) ...)
;;;     (constants (<name> <integer>) ...)        ; optional
;;;     (ops <op> ...)
;;;     (expected-output (<name> <integer>) ...)) ; optional
;;;
;;; Ops:
;;;   (alloc <name> <width>)
;;;   (free <name>)
;;;   (x   (<reg> <idx>))
;;;   (cx  (<reg> <idx>) (<reg> <idx>))
;;;   (ccx (<reg> <idx>) (<reg> <idx>) (<reg> <idx>))

;;; ── width caps (guard asm-tier bump allocator territory) ──────
;;;
;;; Per foxhop CLAUDE.md ### ecdsa/ — lumbda asm-tier safety. asm tier
;;; default binary lacks GC; every register width feeds into r15 growth.
;;; Override at top of main.lsp via set! when a phase needs more
;;; headroom — explicit, traceable, never silent.

(define *max-register-width* 4096)
(define *max-ancilla-width*  1024)

(define (assert-width! kind name width)
  (cond
    ((not (integer? width))
     (error "non-integer width" (list kind name width)))
    ((< width 1)
     (error "width must be positive" (list kind name width)))
    ((and (eq? kind 'register) (> width *max-register-width*))
     (error "register width cap exceeded"
            (list 'register name 'requested width
                  'cap *max-register-width*)))
    ((and (eq? kind 'ancilla) (> width *max-ancilla-width*))
     (error "ancilla width cap exceeded"
            (list 'ancilla name 'requested width
                  'cap *max-ancilla-width*)))))

;;; ── circuit builder (mutable cell-of-lists) ───────────────────

;;; Slot 5 (mirrors) is the Phase B step 10 classical-mirror channel:
;;; an alist (name value) tracking the live classical value of a register
;;; as it mutates across ops. Distinct from slot 1 (inputs), which the
;;; simulator reads to seed register start-of-circuit bit patterns and
;;; therefore must NOT be mutated mid-circuit. mod-inv-by-refined!'s
;;; find-classical-value queries the mirror first, falling back to the
;;; bound input — so standalone callers (test-mod-inv-by) need no mirror,
;;; while real-point-add! rebinds its mirror before each mod-inv! call
;;; to feed the current classical value of tx-reg into the refined path.

;;; Slot 6 (emit-fn) is the Phase B step 12 streaming-construction
;;; channel: optional one-argument procedure `(emit-fn op)`. When non-#f,
;;; emit-op! invokes it with each lumbda op form INSTEAD of consing onto
;;; circ-ops. Callers that need O(1) construction RAM (production-width
;;; secp256k1 emit) install a sink that walks each op to its upstream
;;; op-spec representation & drops the lumbda cons graph immediately.
;;; Default #f preserves the legacy accumulator path so every existing
;;; test & sweep keeps working byte-identical.

(define (make-circuit)
  (vector '() '() '() '() '() '() #f))
  ;; registers, inputs, constants, ops, expected, mirrors, emit-fn

(define (circ-registers c) (vector-ref c 0))
(define (circ-inputs    c) (vector-ref c 1))
(define (circ-constants c) (vector-ref c 2))
(define (circ-ops       c) (vector-ref c 3))
(define (circ-expected  c) (vector-ref c 4))
(define (circ-mirrors   c) (vector-ref c 5))
(define (circ-emit-fn   c) (vector-ref c 6))

(define (set-circ-registers! c v) (vector-set! c 0 v))
(define (set-circ-inputs!    c v) (vector-set! c 1 v))
(define (set-circ-constants! c v) (vector-set! c 2 v))
(define (set-circ-ops!       c v) (vector-set! c 3 v))
(define (set-circ-expected!  c v) (vector-set! c 4 v))
(define (set-circ-mirrors!   c v) (vector-set! c 5 v))
(define (set-circ-emit-fn!   c v) (vector-set! c 6 v))

;;; ── declarations ──────────────────────────────────────────────

(define (declare-register! c name width)
  (assert-width! 'register name width)
  (set-circ-registers! c (cons (list name width) (circ-registers c))))

;;; *static-circuit-mode* — when #t, lumbda emits a HEAD-style single
;;; circuit that processes any input. Per-input binding (bind-input!,
;;; bind-mirror!, rebind-mirror!) errors so we can't accidentally bake
;;; an a-value into the gate stream; find-classical-value returns #f
;;; so primitives that rely on a classical oracle (mod-inv-by-refined!,
;;; real-point-add!'s K-correction replay) fail loudly instead of
;;; silently producing a per-input circuit. Default #f preserves every
;;; existing research cell's byte-identity.
;;;
;;; To flip on at runtime: cells that want the static-circuit path
;;; do `(set! *static-circuit-mode* #t)` at top alongside their other
;;; substrate flags. Phase C's Makefile wrapper injects this line into
;;; a wrapper-cell.lsp ahead of the cell's body.
;;;
;;; PRIOR REVISION used (getenv "STATIC_CIRCUIT_MODE") for env-driven
;;; activation — lumbda --fast hangs on `getenv` (unbound, late-bind
;;; retries forever). Reverted to plain (define ... #f). 2026-06-12.
(define *static-circuit-mode* #f)

(define (bind-input! c name value)
  (cond
    (*static-circuit-mode*
      (error "bind-input! forbidden under *static-circuit-mode* — a static circuit cannot bake input values" name))
    (else
      (set-circ-inputs! c (cons (list name value) (circ-inputs c))))))

;;; find-bound-input — read the binding for a register name (slot 1 only).
;;; Returns the bound classical integer, or #f if name has no binding.
;;; The simulator's initial-value semantics — never mutated mid-circuit.
(define (find-bound-input c name)
  (let ((row (assoc name (circ-inputs c))))
    (cond
      (row (car (cdr row)))
      (else #f))))

;;; bind-mirror! / rebind-mirror! — Phase B step 10 classical-mirror channel
;;; (slot 5). Distinct from bind-input! because the simulator reads slot 1
;;; to initialize register bit patterns at the START of the circuit;
;;; mutating it mid-stream would change what the simulator believes the
;;; register starts as. The mirror tracks the LIVE classical value of a
;;; register as it mutates across ops. Callers like real-point-add! update
;;; the mirror before each mod-inv! call so mod-inv-by-refined!'s
;;; find-classical-value sees the current classical value.

(define (bind-mirror! c name value)
  (cond
    (*static-circuit-mode*
      (error "bind-mirror! forbidden under *static-circuit-mode* — classical mirror channel requires per-input emit" name))
    (else
      (set-circ-mirrors! c (cons (list name value) (circ-mirrors c))))))

(define (rebind-mirror! c name value)
  "Replace name's existing mirror with a fresh value; bind if absent.
   Mutates in place so circ-mirrors never accumulates stale duplicates."
  (cond
    (*static-circuit-mode*
      (error "rebind-mirror! forbidden under *static-circuit-mode* — classical mirror channel requires per-input emit" name))
    (else
      (let loop ((rest (circ-mirrors c)) (acc '()) (found #f))
        (cond
          ((null? rest)
           (cond
             (found (set-circ-mirrors! c (reverse acc)))
             (else  (bind-mirror!      c name value))))
          ((eq? (car (car rest)) name)
           (loop (cdr rest) (cons (list name value) acc) #t))
          (else
           (loop (cdr rest) (cons (car rest) acc) found)))))))

(define (find-mirror c name)
  (let ((row (assoc name (circ-mirrors c))))
    (cond
      (row (car (cdr row)))
      (else #f))))

;;; find-classical-value — preferred lookup for refined mod-inv. Returns
;;; the mirror value if present (the LIVE classical value), else falls
;;; back to the bound input (the start-of-circuit value). Standalone
;;; callers that never set mirrors get the input — same behavior as
;;; before mirrors existed.
(define (find-classical-value c name)
  (cond
    (*static-circuit-mode* #f)
    (else
      (let ((mv (find-mirror c name)))
        (cond
          (mv mv)
          (else (find-bound-input c name)))))))

(define (bind-constant! c name value)
  (set-circ-constants! c (cons (list name value) (circ-constants c))))

(define (expect-output! c name value)
  (set-circ-expected! c (cons (list name value) (circ-expected c))))

;;; ── gate primitives ───────────────────────────────────────────

;;; emit-op! is the single chokepoint every Phase B primitive
;;; (cuccaro!, mod-add!, mod-mul!, mod-inv*, real-point-add!) bottoms
;;; out at via the gate-x!/gate-cx!/gate-ccx!/alloc!/free! constructors
;;; above. Two-mode dispatch: when (circ-emit-fn c) is set, we hand the
;;; op to a caller-installed sink & skip the accumulator. When unset
;;; (default), we cons onto circ-ops exactly as before. Refactoring
;;; here flows automatically through every primitive — no per-primitive
;;; signature change needed.
(define (emit-op! c op)
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink op))
      (else (set-circ-ops! c (cons op (circ-ops c)))))))

;;; Fast-path gate constructors: when (circ-emit-fn c) is set, skip
;;; lumbda S-exp construction entirely & call sink with positional
;;; tag + raw refs. The sink walks ref→qid + builds op-spec in one
;;; shot. Avoids 4 cons cells per gate (mod-mul-solinas! does that
;;; ~256 times per Toffoli at secp256k1 width). Accumulator path
;;; keeps existing S-exp shape so every downstream walker
;;; (point-add->ops, sim.lsp, emit-circuit) sees byte-identical input.
;;;
;;; Sink contract (streaming mode) — FIXED-ARITY 8 args (tag + 7 slots):
;;;   (sink 'x   reg  idx  #f   #f   #f   #f   #f)  — gate-x
;;;   (sink 'cx  cr   ci   tr   ti   #f   #f   #f)  — gate-cx
;;;   (sink 'ccx c1r  c1i  c2r  c2i  tr   ti   #f)  — gate-ccx
;;;   (sink 'alloc name width #f   #f   #f   #f   #f) — alloc
;;;   (sink 'free  name  #f  #f   #f   #f   #f   #f) — free
;;;
;;; Fixed-arity dispatch avoids lumbda's variadic-args list allocation
;;; (which costs ~one Pair per call). At secp256k1 width with ~100M
;;; gates, that's ~100M extra Pair allocations on the hot path —
;;; benchmark showed sink call cost dropping from ~600 us/op to a
;;; few μs/op. Unused slots hold #f sentinel.

(define (gate-x! c reg idx)
  "NOT on a single qubit. Clifford."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'x reg idx #f #f #f #f #f))
      (else (set-circ-ops! c (cons (list 'x (list reg idx)) (circ-ops c)))))))

(define (gate-cx! c ctrl-reg ctrl-idx tgt-reg tgt-idx)
  "Controlled-NOT (CNOT). Clifford."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'cx ctrl-reg ctrl-idx tgt-reg tgt-idx #f #f #f))
      (else (set-circ-ops! c
              (cons (list 'cx
                          (list ctrl-reg ctrl-idx)
                          (list tgt-reg  tgt-idx))
                    (circ-ops c)))))))

(define (gate-ccx! c c1-reg c1-idx c2-reg c2-idx tgt-reg tgt-idx)
  "Doubly-controlled-NOT (Toffoli). One Toffoli charge."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'ccx c1-reg c1-idx c2-reg c2-idx tgt-reg tgt-idx #f))
      (else (set-circ-ops! c
              (cons (list 'ccx
                          (list c1-reg c1-idx)
                          (list c2-reg c2-idx)
                          (list tgt-reg tgt-idx))
                    (circ-ops c)))))))

(define (gate-z! c reg idx)
  "Single-qubit phase flip on |1⟩. Clifford. QECCOPS1 op kind 7."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'z reg idx #f #f #f #f #f))
      (else (set-circ-ops! c (cons (list 'z (list reg idx)) (circ-ops c)))))))

(define (gate-cz! c ctrl-reg ctrl-idx tgt-reg tgt-idx)
  "Controlled-phase. Clifford. Kind 9."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'cz ctrl-reg ctrl-idx tgt-reg tgt-idx #f #f #f))
      (else (set-circ-ops! c
              (cons (list 'cz
                          (list ctrl-reg ctrl-idx)
                          (list tgt-reg  tgt-idx))
                    (circ-ops c)))))))

(define (gate-ccz! c c1-reg c1-idx c2-reg c2-idx tgt-reg tgt-idx)
  "Doubly-controlled-phase. One Toffoli charge. Kind 14."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'ccz c1-reg c1-idx c2-reg c2-idx tgt-reg tgt-idx #f))
      (else (set-circ-ops! c
              (cons (list 'ccz
                          (list c1-reg c1-idx)
                          (list c2-reg c2-idx)
                          (list tgt-reg tgt-idx))
                    (circ-ops c)))))))

(define (gate-r! c reg idx)
  "Single-qubit reset to |0⟩ via RNG-driven measure + conditional flip.
   Clifford. Kind 11. CPU sim: sim_cpu.c lines 86-90."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'r reg idx #f #f #f #f #f))
      (else (set-circ-ops! c (cons (list 'r (list reg idx)) (circ-ops c)))))))

;;; ── Tier-2 classical-bit primitives ──────────────────────────────
;;;
;;; Classical bits live as integer IDs in QECCOPS1; analyze.c auto-sizes
;;; num_bits from max(c_target, c_condition) seen across the op stream.
;;; No Register/Append boilerplate needed for bits — caller manages
;;; integer IDs directly (a monotonic counter at point-add scope is
;;; sufficient).
;;;
;;; Sink calling convention for Tier-2 (still fixed-arity-8 to avoid
;;; variadic-args list allocation on the hot path):
;;;   'bit-invert  : (sink 'bit-invert bit-id #f #f #f #f #f #f)
;;;   'bit-store0  : (sink 'bit-store0 bit-id #f #f #f #f #f #f)
;;;   'bit-store1  : (sink 'bit-store1 bit-id #f #f #f #f #f #f)
;;;   'hmr         : (sink 'hmr qreg qidx bit-id #f #f #f #f)
;;;   'push-cond   : (sink 'push-cond bit-id #f #f #f #f #f #f)
;;;   'pop-cond    : (sink 'pop-cond #f #f #f #f #f #f #f)

(define (gate-bit-invert! c bit-id)
  "Flip a classical bit. Kind 3."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'bit-invert bit-id #f #f #f #f #f #f))
      (else (set-circ-ops! c (cons (list 'bit-invert bit-id) (circ-ops c)))))))

(define (gate-bit-store0! c bit-id)
  "Set a classical bit to 0. Kind 4."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'bit-store0 bit-id #f #f #f #f #f #f))
      (else (set-circ-ops! c (cons (list 'bit-store0 bit-id) (circ-ops c)))))))

(define (gate-bit-store1! c bit-id)
  "Set a classical bit to 1. Kind 5."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'bit-store1 bit-id #f #f #f #f #f #f))
      (else (set-circ-ops! c (cons (list 'bit-store1 bit-id) (circ-ops c)))))))

(define (gate-hmr! c qreg qidx bit-id)
  "Hadamard + Measure + Reset on a qubit, measured outcome into a
   classical bit. Clifford. Kind 12. CPU sim: sim_cpu.c lines 79-85.
   RNG consumes one u64 from the shake stream per shot."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'hmr qreg qidx bit-id #f #f #f #f))
      (else (set-circ-ops! c
              (cons (list 'hmr (list qreg qidx) bit-id)
                    (circ-ops c)))))))

(define (gate-push-cond! c bit-id)
  "Push current base_cond onto stack, narrow base_cond by ANDing with
   bit. Subsequent ops execute conditionally on bit=1. Kind 15."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'push-cond bit-id #f #f #f #f #f #f))
      (else (set-circ-ops! c (cons (list 'push-cond bit-id) (circ-ops c)))))))

(define (gate-pop-cond! c)
  "Pop base_cond off the stack. Restores prior conditional scope. Kind 16."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'pop-cond #f #f #f #f #f #f #f))
      (else (set-circ-ops! c (cons (list 'pop-cond) (circ-ops c)))))))

;;; ── bit-register ↔ qubit-register interop ────────────────────────
;;;
;;; Static-circuit substrate. HEAD's load_bits / unload_bits (adder.rs:
;;; 293) materialize a classical bit-register into a quantum scratch
;;; register via per-position conditional-X: push-cond(bit) + X(q) +
;;; pop-cond. Equivalent to b.x_if(qs[i], bits[i]) in HEAD's API.
;;;
;;; Unlike load-const! / unload-const! (mod-arith.lsp), these do NOT
;;; bake a classical integer into the gate stream — the bit-register's
;;; runtime value is whatever the test driver wrote via gate-bit-store0!
;;; / gate-bit-store1! / hmr. This is the per-shot input channel for a
;;; static circuit (ox, oy in HEAD's emit_dialog_gcd_raw_pa).
;;;
;;; bits-list: a Scheme list of n bit-ID integers (the offset_x or
;;; offset_y bit register). load-bits! / unload-bits! are self-inverse
;;; (cx-via-push-x-pop is its own inverse) — same shape as load-const!.

(define (load-bits! c qs-reg bits-list n)
  "qs-reg[i] ^= bits-list[i] for i in [0, n). qs-reg must be n-wide,
   |0> on entry; on exit holds the bit-register's runtime value."
  (let loop ((i 0) (rest bits-list))
    (cond
      ((or (= i n) (null? rest)) #f)
      (else
        (gate-push-cond! c (car rest))
        (gate-x!         c qs-reg i)
        (gate-pop-cond!  c)
        (loop (+ i 1) (cdr rest))))))

(define (unload-bits! c qs-reg bits-list n)
  "Inverse of load-bits! (self-inverse: same push-x-pop triple uncomputes
   the load). Returns qs-reg to |0> n-wide, leaving bits-list unchanged."
  (load-bits! c qs-reg bits-list n))

(define (alloc! c name width . hint-rest)
  "Allocate an ancilla register. Counts toward peak-qubit width.

   Optional 4th positional arg: hint-base (integer). When non-#f
   and *allocator-base-hint-enabled* is on at sink-construction
   time, the streaming allocator will try to carve exactly the
   hint-base..hint-base+width window from its range-pool. Hint
   silently ignored when (a) flag off, (b) arg not integer, or
   (c) window not fully contained in any free range. Default-OFF
   semantics preserved — pre-existing 3-arg callers behave
   byte-identically to pre-port master."
  (assert-width! 'ancilla name width)
  (let ((sink     (circ-emit-fn c))
        (hint-base (cond ((null? hint-rest) #f)
                         (else (car hint-rest)))))
    (cond
      (sink (sink 'alloc name width hint-base #f #f #f #f))
      (else (set-circ-ops! c (cons (list 'alloc name width) (circ-ops c)))))))

(define (free! c name)
  "Free an ancilla. Sim asserts every bit returned to zero."
  (let ((sink (circ-emit-fn c)))
    (cond
      (sink (sink 'free name #f #f #f #f #f #f))
      (else (set-circ-ops! c (cons (list 'free name) (circ-ops c)))))))

;;; ── finalize & write portal ───────────────────────────────────

(define (emit-circuit c curve-name)
  "Walk our builder into a finished circuit S-expression."
  (list 'circuit
        (list 'version 1)
        (list 'curve curve-name)
        (cons 'registers (reverse (circ-registers c)))
        (cons 'input     (reverse (circ-inputs c)))
        (cons 'constants (reverse (circ-constants c)))
        (cons 'ops       (reverse (circ-ops c)))
        (cons 'expected-output (reverse (circ-expected c)))))

(define (write-portal! filename sexp)
  "Write an S-expression to a portal file atomically (write tmp, rename)."
  (let ((tmp (string-append filename ".tmp")))
    (let ((port (open-output-file tmp)))
      (write sexp port)
      (newline port)
      (close-port port))
    (rename-file tmp filename)))