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.
430 lines
17 KiB
Text
430 lines
17 KiB
Text
;;; sim.lsp — Reversible bit-level simulator for our S-expression circuits.
|
|
;;;
|
|
;;; Reads a circuit portal, executes its op stream on classical bits,
|
|
;;; counts Toffoli & Clifford gates & peak live qubits, runs a reverse
|
|
;;; pass to confirm reversibility, writes a result portal.
|
|
;;;
|
|
;;; Runs on every lumbda tier — Python, C, asm — byte-identically.
|
|
;;;
|
|
;;; Public entry point: (simulate-portal in-path out-path)
|
|
;;;
|
|
;;; Wire format documented in gates.lsp.
|
|
|
|
;;; ── tiny utilities ────────────────────────────────────────────
|
|
|
|
(define (read-portal filename)
|
|
"Slurp a portal as a single S-expression. Uses file->string +
|
|
read-from-string for cross-tier portability — (read port) on a
|
|
raw file handle falls back to stdin on lumbda's Python tier."
|
|
(read-from-string (file->string filename)))
|
|
|
|
(define (write-portal! filename sexp)
|
|
"Write an S-expression to a file atomically."
|
|
(let ((tmp (string-append filename ".tmp")))
|
|
(let ((port (open-output-file tmp)))
|
|
(write sexp port)
|
|
(newline port)
|
|
(close-port port))
|
|
(rename-file tmp filename)))
|
|
|
|
(define (section sexp tag)
|
|
"Return body (everything past tag) of first child whose head = tag, else #f."
|
|
(let loop ((children (cdr sexp)))
|
|
(cond
|
|
((null? children) #f)
|
|
((and (pair? (car children)) (eq? (car (car children)) tag))
|
|
(cdr (car children)))
|
|
(else (loop (cdr children))))))
|
|
|
|
(define (int->bits n width)
|
|
"Decode integer n into a vector of width bits, LSB at index 0."
|
|
(let ((v (make-vector width 0)))
|
|
(let loop ((i 0) (rest n))
|
|
(if (= i width)
|
|
v
|
|
(begin (vector-set! v i (remainder rest 2))
|
|
(loop (+ i 1) (quotient rest 2)))))))
|
|
|
|
(define (bits->int v)
|
|
"Encode a bit vector (LSB at index 0) back into an integer."
|
|
(let loop ((i 0) (acc 0) (pow 1))
|
|
(if (= i (vector-length v))
|
|
acc
|
|
(loop (+ i 1)
|
|
(+ acc (* (vector-ref v i) pow))
|
|
(* pow 2)))))
|
|
|
|
(define (vector-all-zero? v)
|
|
(let loop ((i 0))
|
|
(cond
|
|
((= i (vector-length v)) #t)
|
|
((not (= (vector-ref v i) 0)) #f)
|
|
(else (loop (+ i 1))))))
|
|
|
|
(define (vector-equal? a b)
|
|
(and (= (vector-length a) (vector-length b))
|
|
(let loop ((i 0))
|
|
(cond
|
|
((= i (vector-length a)) #t)
|
|
((not (= (vector-ref a i) (vector-ref b i))) #f)
|
|
(else (loop (+ i 1)))))))
|
|
|
|
(define (vector-copy v)
|
|
(let* ((n (vector-length v))
|
|
(out (make-vector n 0)))
|
|
(let loop ((i 0))
|
|
(if (= i n)
|
|
out
|
|
(begin (vector-set! out i (vector-ref v i))
|
|
(loop (+ i 1)))))))
|
|
|
|
;;; ── simulator state ───────────────────────────────────────────
|
|
;;;
|
|
;;; State carries:
|
|
;;; regs hash-table: register-name → bit vector (mutable)
|
|
;;; widths hash-table: register-name → declared width
|
|
;;; live integer: sum of current register widths
|
|
;;; peak integer: max live ever reached
|
|
;;; toffoli integer: count of ccx ops
|
|
;;; clifford integer: count of x + cx ops
|
|
|
|
(define (make-sim-state)
|
|
(vector (make-hash-table) ; 0: regs
|
|
(make-hash-table) ; 1: widths
|
|
0 ; 2: live
|
|
0 ; 3: peak
|
|
0 ; 4: toffoli
|
|
0 ; 5: clifford
|
|
'running ; 6: status (running | leaked-ancilla | bad-op)
|
|
(make-hash-table) ; 7: bits (Tier-2 classical bits, int-id → 0/1)
|
|
'() ; 8: cond-stack (Tier-2 push-cond / pop-cond)
|
|
1)) ; 9: cond (Tier-2, current conditional mask, 0 or 1)
|
|
|
|
(define (st-regs s) (vector-ref s 0))
|
|
(define (st-widths s) (vector-ref s 1))
|
|
(define (st-live s) (vector-ref s 2))
|
|
(define (st-peak s) (vector-ref s 3))
|
|
(define (st-toffoli s) (vector-ref s 4))
|
|
(define (st-clifford s) (vector-ref s 5))
|
|
(define (st-status s) (vector-ref s 6))
|
|
(define (st-bits s) (vector-ref s 7))
|
|
(define (st-cond-stack s) (vector-ref s 8))
|
|
(define (st-cond s) (vector-ref s 9))
|
|
|
|
(define (set-live! s v) (vector-set! s 2 v))
|
|
(define (set-peak! s v) (vector-set! s 3 v))
|
|
(define (set-toffoli! s v) (vector-set! s 4 v))
|
|
(define (set-clifford! s v) (vector-set! s 5 v))
|
|
(define (set-status! s v) (vector-set! s 6 v))
|
|
(define (set-cond-stack! s v) (vector-set! s 8 v))
|
|
(define (set-cond! s v) (vector-set! s 9 v))
|
|
|
|
(define (bit-ref s id)
|
|
"Read classical bit; defaults to 0 if not yet set."
|
|
(let ((bits (st-bits s)))
|
|
(cond
|
|
((hash-table-exists? bits id) (hash-table-ref bits id))
|
|
(else 0))))
|
|
|
|
(define (bit-set! s id v)
|
|
(hash-table-set! (st-bits s) id v))
|
|
|
|
(define (st-ok? s) (eq? (st-status s) 'running))
|
|
|
|
(define (touch-peak! s)
|
|
(when (> (st-live s) (st-peak s))
|
|
(set-peak! s (st-live s))))
|
|
|
|
;;; ── register initialization ───────────────────────────────────
|
|
|
|
(define (declare-registers! s registers-section input-section)
|
|
;; registers-section = ((target-x 4) (target-y 4) ...)
|
|
;; input-section = ((target-x 11) (target-y 6) ...)
|
|
(for-each
|
|
(lambda (rec)
|
|
(let ((name (car rec))
|
|
(width (car (cdr rec))))
|
|
(hash-table-set! (st-widths s) name width)
|
|
(let ((initial 0))
|
|
;; lookup input value if present
|
|
(let ((row (assoc name input-section)))
|
|
(when row (set! initial (car (cdr row)))))
|
|
(hash-table-set! (st-regs s) name (int->bits initial width)))
|
|
(set-live! s (+ (st-live s) width))))
|
|
registers-section)
|
|
(touch-peak! s))
|
|
|
|
;;; ── op execution (forward and reverse) ────────────────────────
|
|
|
|
(define (qref->bit s ref)
|
|
"ref = (reg-name idx)."
|
|
(let ((reg (hash-table-ref (st-regs s) (car ref))))
|
|
(vector-ref reg (car (cdr ref)))))
|
|
|
|
(define (qref-flip! s ref)
|
|
(let* ((reg (hash-table-ref (st-regs s) (car ref)))
|
|
(i (car (cdr ref)))
|
|
(cur (vector-ref reg i)))
|
|
(vector-set! reg i (- 1 cur))))
|
|
|
|
(define (exec-op! s op forward?)
|
|
"Apply one op. forward? = #t for forward pass, #f for reverse.
|
|
All Phase B Tier-1 gates {x, z, cx, cz, ccx, ccz, r} are self-inverse
|
|
on classical-bit-valued single-shot state (z/cz/ccz add no observable
|
|
bit-value effect; r unconditionally zeros target). Tier-2 ops
|
|
{bit-invert, bit-store0, bit-store1, hmr, push-cond, pop-cond} require
|
|
reversibility-aware handling — see sweep-013 RESULTS.md for the
|
|
classical-replay design."
|
|
(case (car op)
|
|
((x)
|
|
;; sweep-041: gate on st-cond to match HEAD's sim_cpu.c (line 62):
|
|
;; uint64_t v = cond ...; qubits[tgt] ^= v. Under push-cond=0 the
|
|
;; gate must NOT fire. Tier-2 ops (bit-*, HMR) were already gated;
|
|
;; Tier-1 quantum ops were not until sweep-041 surfaced the gap
|
|
;; via verify-boundary-cond-replay round-trip failure. Clifford
|
|
;; counter also gated to mirror sim_cpu.c line 38-39.
|
|
(when (= (st-cond s) 1)
|
|
(qref-flip! s (car (cdr op)))
|
|
(set-clifford! s (+ (st-clifford s) 1))))
|
|
((z)
|
|
;; Z is phase-only — no effect on classical-bit single-shot state.
|
|
;; Clifford counter gated on cond like other Cliffords.
|
|
(when (= (st-cond s) 1)
|
|
(set-clifford! s (+ (st-clifford s) 1))))
|
|
((cx)
|
|
(when (= (st-cond s) 1)
|
|
(let ((ctrl (car (cdr op)))
|
|
(tgt (car (cdr (cdr op)))))
|
|
(when (= (qref->bit s ctrl) 1)
|
|
(qref-flip! s tgt)))
|
|
(set-clifford! s (+ (st-clifford s) 1))))
|
|
((cz)
|
|
;; CZ is phase-only — no bit-value effect. Gated counter bump.
|
|
(when (= (st-cond s) 1)
|
|
(set-clifford! s (+ (st-clifford s) 1))))
|
|
((ccx)
|
|
(when (= (st-cond s) 1)
|
|
(let ((c1 (car (cdr op)))
|
|
(c2 (car (cdr (cdr op))))
|
|
(tgt (car (cdr (cdr (cdr op))))))
|
|
(when (and (= (qref->bit s c1) 1) (= (qref->bit s c2) 1))
|
|
(qref-flip! s tgt)))
|
|
;; sweep-041: bump Toffoli only on cond=1 — mirrors HEAD's
|
|
;; sim_cpu.c line 37 (toffoli_gates += executed = POPCOUNT(cond)).
|
|
;; Single-shot classical: cond=1 → +1, cond=0 → +0. Without this
|
|
;; gating, cond-replay's "half-shot saving" doesn't show in our
|
|
;; sim's Toffoli count.
|
|
(set-toffoli! s (+ (st-toffoli s) 1))))
|
|
((ccz)
|
|
;; CCZ is phase-only — no bit-value effect. One Toffoli charge,
|
|
;; gated on cond like CCX (matches sim_cpu.c line 36-37).
|
|
(when (= (st-cond s) 1)
|
|
(set-toffoli! s (+ (st-toffoli s) 1))))
|
|
((r)
|
|
;; Single-qubit reset. Under push-cond=0 the reset must NOT fire
|
|
;; (matches HEAD sim_cpu.c line 86-90: qubits &= ~cond). Clifford
|
|
;; counter also gated.
|
|
(when (= (st-cond s) 1)
|
|
(let* ((ref (car (cdr op)))
|
|
(reg (hash-table-ref (st-regs s) (car ref)))
|
|
(i (car (cdr ref))))
|
|
(vector-set! reg i 0))
|
|
(set-clifford! s (+ (st-clifford s) 1))))
|
|
((bit-invert)
|
|
(when (= (st-cond s) 1)
|
|
(let ((id (car (cdr op))))
|
|
(bit-set! s id (- 1 (bit-ref s id))))
|
|
(set-clifford! s (+ (st-clifford s) 1))))
|
|
((bit-store0)
|
|
(when (= (st-cond s) 1)
|
|
(bit-set! s (car (cdr op)) 0)
|
|
(set-clifford! s (+ (st-clifford s) 1))))
|
|
((bit-store1)
|
|
(when (= (st-cond s) 1)
|
|
(bit-set! s (car (cdr op)) 1)
|
|
(set-clifford! s (+ (st-clifford s) 1))))
|
|
((hmr)
|
|
;; Hadamard + Measure + Reset. Forward: bit := qubit, qubit := 0.
|
|
;; Reverse: qubit := bit, bit := 0. Gated on conditional. Clifford
|
|
;; counter also gated for consistency with sim_cpu.c line 38-39.
|
|
(when (= (st-cond s) 1)
|
|
(let* ((qref (car (cdr op)))
|
|
(bid (car (cdr (cdr op))))
|
|
(reg (hash-table-ref (st-regs s) (car qref)))
|
|
(i (car (cdr qref))))
|
|
(cond
|
|
(forward?
|
|
(bit-set! s bid (vector-ref reg i))
|
|
(vector-set! reg i 0))
|
|
(else
|
|
(vector-set! reg i (bit-ref s bid))
|
|
(bit-set! s bid 0))))
|
|
(set-clifford! s (+ (st-clifford s) 1))))
|
|
((push-cond)
|
|
;; Forward: stack.push(cond); cond := cond AND bit.
|
|
;; Reverse: cond := stack.pop().
|
|
(cond
|
|
(forward?
|
|
(set-cond-stack! s (cons (st-cond s) (st-cond-stack s)))
|
|
(let ((bid (car (cdr op))))
|
|
(set-cond! s (* (st-cond s) (bit-ref s bid)))))
|
|
(else
|
|
(cond
|
|
((null? (st-cond-stack s))
|
|
(set-status! s 'pop-empty-stack))
|
|
(else
|
|
(set-cond! s (car (st-cond-stack s)))
|
|
(set-cond-stack! s (cdr (st-cond-stack s))))))))
|
|
((pop-cond)
|
|
;; Forward: cond := stack.pop().
|
|
;; Reverse: stack.push(cond); cond := cond AND ??? — pop-cond
|
|
;; carries no bit-id, so reverse cannot reconstruct the narrowing.
|
|
;; Pop-cond's reverse therefore just pushes current cond.
|
|
;; (This is reversible iff push-cond and pop-cond bracket cleanly.)
|
|
(cond
|
|
(forward?
|
|
(cond
|
|
((null? (st-cond-stack s))
|
|
(set-status! s 'pop-empty-stack))
|
|
(else
|
|
(set-cond! s (car (st-cond-stack s)))
|
|
(set-cond-stack! s (cdr (st-cond-stack s))))))
|
|
(else
|
|
(set-cond-stack! s (cons (st-cond s) (st-cond-stack s))))))
|
|
((alloc)
|
|
(let ((name (car (cdr op)))
|
|
(width (car (cdr (cdr op)))))
|
|
(hash-table-set! (st-widths s) name width)
|
|
(if forward?
|
|
(begin
|
|
(hash-table-set! (st-regs s) name (make-vector width 0))
|
|
(set-live! s (+ (st-live s) width))
|
|
(touch-peak! s))
|
|
(let ((reg (hash-table-ref (st-regs s) name)))
|
|
(if (vector-all-zero? reg)
|
|
(begin
|
|
(hash-table-delete! (st-regs s) name)
|
|
(set-live! s (- (st-live s) width)))
|
|
(set-status! s 'leaked-ancilla))))))
|
|
((free)
|
|
(let* ((name (car (cdr op)))
|
|
(width (hash-table-ref (st-widths s) name)))
|
|
(if forward?
|
|
(let ((reg (hash-table-ref (st-regs s) name)))
|
|
(if (vector-all-zero? reg)
|
|
(begin
|
|
(hash-table-delete! (st-regs s) name)
|
|
(set-live! s (- (st-live s) width)))
|
|
(set-status! s 'leaked-ancilla)))
|
|
(begin
|
|
(hash-table-set! (st-regs s) name (make-vector width 0))
|
|
(set-live! s (+ (st-live s) width))
|
|
(touch-peak! s)))))
|
|
(else (set-status! s 'bad-op))))
|
|
|
|
(define (run-ops! s ops forward?)
|
|
"Walk ops in order, halting on first state-status flip."
|
|
(let loop ((rest ops))
|
|
(cond
|
|
((null? rest) #t)
|
|
((not (st-ok? s)) #f)
|
|
(else
|
|
(exec-op! s (car rest) forward?)
|
|
(loop (cdr rest))))))
|
|
|
|
;;; ── simulate one circuit, return result S-expression ──────────
|
|
|
|
(define (simulate circuit)
|
|
(let* ((regs-sect (section circuit 'registers))
|
|
(input-sect (section circuit 'input))
|
|
(ops-sect (section circuit 'ops))
|
|
(expected (section circuit 'expected-output))
|
|
(s (make-sim-state)))
|
|
(declare-registers! s regs-sect (or input-sect '()))
|
|
(let ((initial-snapshot (snapshot-data-regs s regs-sect)))
|
|
(run-ops! s ops-sect #t)
|
|
(if (not (st-ok? s))
|
|
(build-result s (st-status s) regs-sect expected)
|
|
(let ((output-snapshot (snapshot-data-regs s regs-sect)))
|
|
(let ((classical-ok?
|
|
(or (null? expected)
|
|
(expected-matches? expected output-snapshot))))
|
|
(set-toffoli! s 0)
|
|
(set-clifford! s 0)
|
|
(run-ops! s (reverse ops-sect) #f)
|
|
(let ((restored? (and (st-ok? s)
|
|
(snapshot-equals? s initial-snapshot))))
|
|
(cond
|
|
((not classical-ok?)
|
|
(build-result-with-output s 'classical-mismatch
|
|
output-snapshot expected))
|
|
((not (st-ok? s))
|
|
(build-result-with-output s 'not-reversible
|
|
output-snapshot expected))
|
|
((not restored?)
|
|
(build-result-with-output s 'not-reversible
|
|
output-snapshot expected))
|
|
(else
|
|
(build-result-with-output s 'ok
|
|
output-snapshot expected))))))))))
|
|
|
|
(define (snapshot-data-regs s regs-sect)
|
|
"Return alist (name . bit-vector) for declared data registers only."
|
|
(map
|
|
(lambda (rec)
|
|
(let ((name (car rec)))
|
|
(cons name (vector-copy (hash-table-ref (st-regs s) name)))))
|
|
regs-sect))
|
|
|
|
(define (snapshot-equals? s snap)
|
|
"Check every register in snap matches current state."
|
|
(let loop ((rest snap))
|
|
(cond
|
|
((null? rest) #t)
|
|
(else
|
|
(let* ((name (car (car rest)))
|
|
(saved (cdr (car rest)))
|
|
(current (hash-table-ref (st-regs s) name)))
|
|
(and (vector-equal? saved current) (loop (cdr rest))))))))
|
|
|
|
(define (expected-matches? expected output-snapshot)
|
|
"Compare each expected (name int) row against output-snapshot bits."
|
|
(let loop ((rest expected))
|
|
(cond
|
|
((null? rest) #t)
|
|
(else
|
|
(let* ((name (car (car rest)))
|
|
(want (car (cdr (car rest))))
|
|
(got-vec (cdr (assoc name output-snapshot)))
|
|
(got (bits->int got-vec)))
|
|
(and (= want got) (loop (cdr rest))))))))
|
|
|
|
(define (build-result s status regs-sect expected)
|
|
(build-result-with-output s status
|
|
(snapshot-data-regs s regs-sect)
|
|
expected))
|
|
|
|
(define (build-result-with-output s status snap expected)
|
|
(let ((output-rows
|
|
(map (lambda (rec)
|
|
(list (car rec) (bits->int (cdr rec))))
|
|
snap))
|
|
(toffoli (st-toffoli s))
|
|
(peak (st-peak s)))
|
|
(list 'result
|
|
(list 'status status)
|
|
(cons 'output output-rows)
|
|
(list 'counts
|
|
(list 'toffoli toffoli)
|
|
(list 'clifford (st-clifford s))
|
|
(list 'peak-qubits peak))
|
|
(list 'score (* toffoli peak)))))
|
|
|
|
;;; ── top-level entrypoint ──────────────────────────────────────
|
|
|
|
(define (simulate-portal in-path out-path)
|
|
"Read circuit portal, simulate, write result portal."
|
|
(let* ((circuit (read-portal in-path))
|
|
(result (simulate circuit)))
|
|
(write-portal! out-path result)
|
|
result))
|