From 1665893321587c791fc1a701700ae5c1afd2d322 Mon Sep 17 00:00:00 2001 From: "russell@unturf.com" Date: Sun, 14 Jun 2026 10:37:35 -0400 Subject: [PATCH] factory + quantum + sweep-doctrine: AGPLv3 share-back from foxhop ecdsa 29 new files publish factory infra (V2 autoscaler with live VRAM sampling + EWMA peak tracking, HUGE solo-dispatch, two-tier DLQ/rDLQ classifier + retry), general quantum circuit primitives (Cuccaro ripple-carry adder, Clifford gate library, Clifford tableau simulator, mod-arith family, dialog GCD reversible inverse, Karatsuba multiplier, Solinas fast reduction), and a TCRAUDT reducer harness. Originally developed in ~/git/www.foxhop.net/ecdsa/ for secp256k1 attack-surface research; published upstream as obligated by AGPLv3. Parametrization contract at factory/CONTRACT.md. Consumers export LUMBDA_REPO_DIR + LUMBDA_QUEUE_DIR + LUMBDA_BACKEND_CMD + LUMBDA_EMITTER_CMD then exec factory scripts. No fork-and-modify; single source of truth upstream. Integration tests gate 7 V2 defect classes that wedged a live factory on 2026-06-12 (skewed-demand starve, zero-floor reservation, multi-tier greedy, +-25%% damping, cold-start ramp, DLQ surge halve, post-damp CPU ceiling) + 28 DLQ classifier cases (auto-retry vs escalate partition) + bash -n syntax lint across every script. GPU backend stays in consumer trees; rationale in factory/GPU-BACKEND-NOTE.md. Bend wire protocol + gpu-worker.lsp already upstream at examples/cuda-fanout/. make factory-lint bash -n on every factory/*.sh make test-integration V2 reducer + DLQ classifier + syntax gate make sweep-doctrine TCRAUDT reducer gate (serial) make sweep-doctrine-parallel xargs -P fan-out Verified on neoblanka: factory-lint 12 scripts PASS; test-integration 14 V2 cases + 28 DLQ classifier cases + 12 syntax cases all PASS. --- Makefile | 35 + factory/CHANGELOG.md | 16 + factory/CONTRACT.md | 62 + factory/GPU-BACKEND-NOTE.md | 29 + factory/README.md | 93 + factory/bend-autoscaler.sh | 765 ++ factory/bend-dispatcher.sh | 192 + factory/bend-emit-pool.sh | 502 ++ factory/bend-supervisor-dlq-runner.sh | 278 + factory/bend-supervisor.sh | 353 + factory/lib-heartbeat.sh | 108 + factory/lib-tier.sh | 203 + quantum/README.md | 43 + quantum/adder.lsp | 2824 ++++++++ quantum/gates.lsp | 441 ++ quantum/mod-arith.lsp | 6127 +++++++++++++++++ quantum/mod-inv-by-dialog-gcd-host.lsp | 900 +++ quantum/mod-inv-by-dialog-gcd.lsp | 1714 +++++ quantum/mod-inv-by.lsp | 1382 ++++ quantum/mod-karatsuba.lsp | 838 +++ quantum/mod-solinas.lsp | 595 ++ quantum/score.lsp | 104 + quantum/sim.lsp | 430 ++ tests/integration/test-autoscaler-v2.sh | 306 + tests/integration/test-bash-script-syntax.sh | 85 + tests/integration/test-dlq-runner-classify.sh | 178 + tests/sweep-doctrine/README.md | 53 + tests/sweep-doctrine/lib.lsp | 73 + tests/sweep-doctrine/run-parallel.sh | 159 + tests/sweep-doctrine/run.sh | 126 + 30 files changed, 19014 insertions(+) create mode 100644 factory/CHANGELOG.md create mode 100644 factory/CONTRACT.md create mode 100644 factory/GPU-BACKEND-NOTE.md create mode 100644 factory/README.md create mode 100755 factory/bend-autoscaler.sh create mode 100755 factory/bend-dispatcher.sh create mode 100755 factory/bend-emit-pool.sh create mode 100755 factory/bend-supervisor-dlq-runner.sh create mode 100755 factory/bend-supervisor.sh create mode 100755 factory/lib-heartbeat.sh create mode 100755 factory/lib-tier.sh create mode 100644 quantum/README.md create mode 100644 quantum/adder.lsp create mode 100644 quantum/gates.lsp create mode 100644 quantum/mod-arith.lsp create mode 100644 quantum/mod-inv-by-dialog-gcd-host.lsp create mode 100644 quantum/mod-inv-by-dialog-gcd.lsp create mode 100644 quantum/mod-inv-by.lsp create mode 100644 quantum/mod-karatsuba.lsp create mode 100644 quantum/mod-solinas.lsp create mode 100644 quantum/score.lsp create mode 100644 quantum/sim.lsp create mode 100755 tests/integration/test-autoscaler-v2.sh create mode 100755 tests/integration/test-bash-script-syntax.sh create mode 100755 tests/integration/test-dlq-runner-classify.sh create mode 100644 tests/sweep-doctrine/README.md create mode 100644 tests/sweep-doctrine/lib.lsp create mode 100755 tests/sweep-doctrine/run-parallel.sh create mode 100755 tests/sweep-doctrine/run.sh diff --git a/Makefile b/Makefile index ba63c13..1662d99 100644 --- a/Makefile +++ b/Makefile @@ -224,6 +224,40 @@ endif gpu-worker-test: gpu-worker-bin $(MAKE) -C $(GPU_WORKER_DIR) test +# ─── Factory — bend at scale ────────────────────────────────────── +# +# Bounded-parallel emit + dispatch + autoscaling for lumbda research +# loops driving GPU bend backends. See factory/README.md & factory/CONTRACT.md. +# Originally built at foxhop for secp256k1 attack-surface research; shared +# upstream under AGPLv3. +# +# make factory-lint bash -n syntax check on factory/*.sh +# make test-integration integration tests (autoscaler V2 reducer + DLQ classifier) +# make sweep-doctrine TCRAUDT reducer gate (serial) +# make sweep-doctrine-parallel same, xargs -P fan-out (JOBS=N) +# +# Consumer wrapper pattern: domain repos export LUMBDA_* env then exec +# factory/bend-supervisor.sh. See factory/CONTRACT.md. + +FACTORY_DIR := factory +TESTS_INTEGRATION_DIR := tests/integration +TESTS_SWEEP_DOCTRINE_DIR := tests/sweep-doctrine + +factory-lint: + @bash $(TESTS_INTEGRATION_DIR)/test-bash-script-syntax.sh + +test-integration: + @for t in $(TESTS_INTEGRATION_DIR)/test-*.sh; do \ + echo "── $$t ──"; \ + bash "$$t" || { rc=$$?; [ $$rc -eq 77 ] && echo "SKIP (factory script absent)" || exit $$rc; }; \ + done + +sweep-doctrine: + @bash $(TESTS_SWEEP_DOCTRINE_DIR)/run.sh + +sweep-doctrine-parallel: + @bash $(TESTS_SWEEP_DOCTRINE_DIR)/run-parallel.sh + # ─── Documentation ──────────────────────────────────────────────── DOT_FILES := $(wildcard docs/*.dot) @@ -296,4 +330,5 @@ clean-all: clean clean-whitepaper clean-docs c-clean asm-clean test-all bench-all examples friction functional-test portal-rng-cross-test \ bench-3way bench-portal bench-portal-cross bench-web bench-rpc-chain bench-proof \ gpu-worker gpu-worker-bin gpu-worker-test \ + factory-lint test-integration sweep-doctrine sweep-doctrine-parallel \ docs whitepaper clean clean-whitepaper clean-docs clean-all diff --git a/factory/CHANGELOG.md b/factory/CHANGELOG.md new file mode 100644 index 0000000..7e9967a --- /dev/null +++ b/factory/CHANGELOG.md @@ -0,0 +1,16 @@ +# factory CHANGELOG + +## 2026-06-14 — initial upstream port + +AGPLv3 share-back from foxhop ecdsa secp256k1 attack-surface research. Port covers: + +- V2 live-state autoscaler (EWMA peak tracking, DLQ growth-rate damping, HUGE solo-dispatch, ±25 % per-poll damping, cold-recovery baseline) +- Bounded parallel emit pool with auto-pull-master across multiple repos +- Singleton dispatcher with live tier-config reload +- Two-tier DLQ + rDLQ with class-based auto-retry vs escalate +- Tier classifier (micro/small/medium/large/huge bin bands) +- Supervisor liveness signaling + +Env-var contract defined in `CONTRACT.md`. Consumers wrap by exporting env then exec'ing upstream scripts. Single source of truth — no fork-and-modify. + +Provenance: foxhop scripts at `~/git/www.foxhop.net/ecdsa/scripts/bend-*` operated this factory from 2026-05 through 2026-06-14, producing measured improvements documented in foxhop's PROVENANCE.md. diff --git a/factory/CONTRACT.md b/factory/CONTRACT.md new file mode 100644 index 0000000..d927b36 --- /dev/null +++ b/factory/CONTRACT.md @@ -0,0 +1,62 @@ +# Factory env-var contract + +Every upstream factory script reads these env vars. Consumers (foxhop ecdsa, any future lumbda-driven research repo) set them before sourcing or exec'ing factory scripts. Defaults assume a generic lumbda development setup; consumers override for their domain. + +## Path knobs + +| Var | Default | Purpose | +|---|---|---| +| `LUMBDA_REPO_DIR` | `$HOME/git/lumbda` | Git repo to `git pull --ff-only origin master` at top of every emit-loop iter. Consumers override to their own repo (e.g. foxhop sets `$HOME/git/www.foxhop.net`). | +| `LUMBDA_FACTORY_DIR` | `$LUMBDA_REPO_DIR/factory` | Where upstream factory scripts live. Used for inter-script `exec`/`source` resolution. | +| `LUMBDA_QUEUE_DIR` | `/tmp/lumbda-queue` | Runtime queue + DLQ + rDLQ + supervisor.config home. One per running factory instance. | +| `LUMBDA_DOMAIN_DIR` | unset | Optional domain root (consumer repo's working subdir). Foxhop sets `$HOME/git/www.foxhop.net/ecdsa`. Scripts that resolve `.lsp` cell paths look here. | + +## Backend knobs + +| Var | Default | Purpose | +|---|---|---| +| `LUMBDA_BACKEND_CMD` | `bend-cuda` | Command the dispatcher exec's per cell. Receives `--portal ` as first arg. Consumers point at their compiled backend binary. | +| `LUMBDA_BACKEND_PROC_PATTERN` | `bend-cuda` | `pgrep -f` pattern to count running backend forks for VRAM accounting. Usually same basename as `LUMBDA_BACKEND_CMD`. | +| `LUMBDA_EMITTER_CMD` | unset | Optional emit-side command run by `bend-emit-pool` per `.lsp` cell. If unset, pool only manages queue lifecycle (no emit). Foxhop sets a full `lumbda --fast .../emit-stream.lsp` invocation. | + +## Remote knobs + +| Var | Default | Purpose | +|---|---|---| +| `LUMBDA_REMOTE` | unset (local) | SSH target (e.g. `user@host`) for remote factory ops. Empty = run locally. | +| `LUMBDA_REMOTE_SSH_OPTS` | `-o BatchMode=yes -o ConnectTimeout=10` | SSH options for remote calls. | + +## Autoscaler V2 knobs (all already env-var-gated in source) + +| Var | Default | Purpose | +|---|---|---| +| `AUTOSCALER_V2` | `1` | `0` falls back to V1 controller (legacy). | +| `AUTOSCALER_PEAK_INITIAL` | `4096` | Initial per-worker VRAM estimate (MiB). | +| `AUTOSCALER_CPU_CEILING` | `30` | Total worker hard cap (cores + modest oversub). | +| `AUTOSCALER_DLQ_DAMPING_THRESHOLD` | `10` | DLQ entries-per-poll above which damping fires. | +| `AUTO_PULL_MASTER` | `1` | Auto-pull at top of each emit iter (0 disables). | +| `AUTO_PULL_TIMEOUT` | `30` | Seconds for git pull. | +| `LUMBDA_AUTO_PULL_DIRS` | `$LUMBDA_REPO_DIR` | Colon-separated repo dirs to pull each iter. Consumer with both upstream lumbda + domain repo sets e.g. `$HOME/git/lumbda:$HOME/git/www.foxhop.net`. Both pull `--ff-only origin master`; either failure logged as PULL-FAIL but does not abort emit. | +| `TIER__DISPATCH_CEILING` | 24/16/12/6/1 | Per-tier hard cap (micro/small/medium/large/huge). | +| `TIER__MAX` | varies | Per-tier bin-size ceiling (MiB). See `lib-tier.sh`. | +| `TIER_CONFIG_LIVE_RELOAD` | `1` | Dispatcher re-reads supervisor.config per dispatch (no restart needed). | + +## Discipline + +- Defaults stay generic. Consumers override via wrapper scripts that `export` then `exec`. +- Scripts NEVER hardcode `/tmp/ecdsa-queue`, `bend-cuda`, host names, or repo paths. Always read from env. +- New knobs land with default + table entry above. CHANGELOG entry on add. +- `LUMBDA_FACTORY_DIR/CONTRACT.md` (this file) stays single source of truth; never duplicate var docs in script comment blocks beyond a one-line pointer. + +## Consumer wrapper pattern + +```bash +#!/bin/bash +# foxhop ecdsa/scripts/bend-supervisor — wraps upstream lumbda factory +export LUMBDA_REPO_DIR="$HOME/git/www.foxhop.net" +export LUMBDA_DOMAIN_DIR="$HOME/git/www.foxhop.net/ecdsa" +export LUMBDA_QUEUE_DIR="/tmp/ecdsa-queue" +export LUMBDA_BACKEND_CMD="$LUMBDA_DOMAIN_DIR/cuda/bend-cuda" +export LUMBDA_EMITTER_CMD="lumbda --fast $LUMBDA_DOMAIN_DIR/lumbda/emit-stream.lsp" +exec "$HOME/git/lumbda/factory/bend-supervisor.sh" "$@" +``` diff --git a/factory/GPU-BACKEND-NOTE.md b/factory/GPU-BACKEND-NOTE.md new file mode 100644 index 0000000..fba73da --- /dev/null +++ b/factory/GPU-BACKEND-NOTE.md @@ -0,0 +1,29 @@ +# GPU backend — scope note + +## What lives upstream + +- **bend wire protocol** — `examples/cuda-fanout/` (`gpu-worker.lsp`, `bend.lsp`, `bend-macros.lsp`, `wire.lsp`). S-expression + binary (`BSHK` magic) modes. Tier-agnostic — runs under Python, C, or asm tier. +- **GPU launcher** — `make gpu-worker LUMBDA={c,python,asm} PORT=NNNN`. Spawns gpu-worker.lsp on chosen tier. +- **Factory** — `factory/` orchestrates a queue of cells against any backend reachable via `LUMBDA_BACKEND_CMD`. Backend-agnostic. + +## What stays in a domain consumer + +Specific GPU simulator backends (Clifford tableau, stabilizer, surface-code) couple deeply to a research domain's operation set. They live in domain consumers: + +- Foxhop ecdsa Clifford tableau simulator: `~/git/www.foxhop.net/ecdsa/cuda/` — secp256k1 group operations, `BSHK` binary ops format with secp-specific opcodes. + +These backends accept a portal-file interface and expose `LUMBDA_BACKEND_CMD`-compatible call shape. Consumers point factory at their backend; factory provides everything around it (queue, autoscaling, DLQ, tier admission). + +## Why a generic Clifford backend stays out of this port + +A truly upstream Clifford simulator would need: + +1. **Generic ops format** — abstract over per-domain instruction sets (currently `main_ops.c` carries secp-specific group ops). +2. **Domain-agnostic memory model** — current tableau layout sized for n=257 qubits + ancilla; would need width-parametric VRAM accounting. +3. **Standalone test coverage** — current correctness gates run against secp256k1 truth tables. + +Each is several days' work + a research-quality decision (which Clifford simulator family becomes canonical upstream). Out of scope for this AGPLv3 share-back. Filed as future work. + +## What this means for AGPLv3 compliance + +The factory + lumbda quantum primitives discharge the share-back. The domain-specific backend belongs to consumer repos under their own license (AGPLv3 if derivative). Foxhop's `ecdsa/cuda/` remains AGPLv3 in its tree. diff --git a/factory/README.md b/factory/README.md new file mode 100644 index 0000000..d436aae --- /dev/null +++ b/factory/README.md @@ -0,0 +1,93 @@ +# factory/ — bend at scale + +Bounded-parallel emit + dispatch + autoscaling for lumbda research loops driving GPU bend backends. Originally built for foxhop ecdsa secp256k1 attack-surface work (`~/git/www.foxhop.net/ecdsa/`), shared back upstream under AGPLv3. + +## What it does + +Drives a queue of `.lsp` cells → emitted `.bin` payloads → dispatched to a backend (default `bend-cuda`) → results in a portal file. Survives crashes, OOM, transient CUDA errors via a two-tier DLQ. Adapts concurrency to live VRAM headroom + observed per-fork peak memory. + +## Components + +- `bend-supervisor.sh` — process orchestrator. Launches pool + dispatcher + autoscaler + DLQ runner. +- `bend-emit-pool.sh` — bounded parallel emit loop. Auto-pulls `LUMBDA_REPO_DIR` per iter. +- `bend-dispatcher.sh` — singleton dispatcher. Reads supervisor.config tier caps live, dispatches `.bin` to backend. +- `bend-autoscaler.sh` — V2 live-state controller. Samples VRAM free + running forks + EWMA peak → plans per-tier caps. +- `bend-supervisor-dlq-runner.sh` — DLQ classifier. Auto-retries transient classes, escalates persistent to rDLQ. +- `lib-tier.sh` — bin-size classifier. Tier bands + HUGE solo-dispatch. +- `lib-heartbeat.sh` — supervisor liveness signaling. + +## V2 controller — live VRAM model + +Rather than reserving `PEAK × allocated_slots` for every tier (V1's approach, prone to over-reservation under skew), V2 samples actual state: + +- `nvidia-smi --query-gpu=memory.free` → live headroom (not fixed budget × fraction) +- `pgrep -f "$LUMBDA_BACKEND_PROC_PATTERN"` + `nvidia-smi --query-compute-apps=used_memory` → fork count + observed peak +- EWMA over observed peaks → per-worker VRAM estimate (file `autoscaler.ewma`) +- Zero-floor on empty tiers (no `MIN=1` reservation) +- Fall-through admission (single-tier demand → grant whole budget to that tier) +- ±25 % per-poll rate-of-change damping +- DLQ growth-rate damping (halve next plan if DLQ growth > threshold) + +See `bend-autoscaler.sh` header for signal format + operator overrides. + +## HUGE solo-dispatch + +Cells that classify as HUGE (4-12 GB bins) get whole-card solo dispatch: when a HUGE bin is queued or in flight, all other tiers plan to 0 until HUGE completes. Damped at 25 %/poll so already-running cells finish naturally (~2 min drain). + +Trigger: `r_huge > 0` OR `inflight_huge > 0`. Release: `inflight_huge = 0` AND no queued HUGE. + +## Two-tier DLQ + rDLQ + +`bend-supervisor-dlq-runner.sh` polls `$LUMBDA_QUEUE_DIR/dlq/` every 30s. Per entry, classifies + acts: + +- **Auto-retry classes** (`missing-bin`, `bisect-pool-race`, `cuda-error-transient`, `no-portal`) → move `.bin` back to queue, `.ready` touched, `.retries++`. Cap `AUTO_RETRY_MAX=3` then escalates. +- **Escalate classes** (`cuda-oom`, `cuda-illegal-addr`, `memory-cap-refused`, `bin-load-fail`, `tier-classify`, `emit-broken`, `unknown`) → move to `$LUMBDA_QUEUE_DIR/rdlq/` with full state preservation. Owner inspects + patches + retries. + +rDLQ state per cell: +``` +rdlq/.bin (preserved iff stage != emit AND salvage=yes) +rdlq/.lsp (cell source — required for retry-reemit path) +rdlq/.reason (original DLQ reason + classifier verdict) +rdlq/.class (cuda-oom | bin-load-fail | ...) +rdlq/.stage (emit | dispatch | sim) +rdlq/.retries (cumulative) +rdlq/.first-seen (UTC timestamp) +``` + +## Cold-recovery baseline + +V2 writes `$LUMBDA_QUEUE_DIR/supervisor.config.baseline` every poll iff `total >= CPU_CEILING/4`. Last known-healthy cap vector. On autoscaler crash with stale `supervisor.config`: + +```bash +cp "$LUMBDA_QUEUE_DIR/supervisor.config.baseline" "$LUMBDA_QUEUE_DIR/supervisor.config" +``` + +then restart `bend-autoscaler.sh`. Baseline overwritten each healthy poll, tracks workload evolution. + +## Configuration + +All knobs in `CONTRACT.md`. Defaults assume a generic lumbda dev setup; domain consumers (foxhop ecdsa, etc.) set env vars then exec. + +Example consumer wrapper: +```bash +#!/bin/bash +export LUMBDA_REPO_DIR="$HOME/git/www.foxhop.net" +export LUMBDA_DOMAIN_DIR="$HOME/git/www.foxhop.net/ecdsa" +export LUMBDA_QUEUE_DIR="/tmp/ecdsa-queue" +export LUMBDA_BACKEND_CMD="$LUMBDA_DOMAIN_DIR/cuda/bend-cuda" +export LUMBDA_EMITTER_CMD="lumbda --fast $LUMBDA_DOMAIN_DIR/lumbda/emit-stream.lsp" +exec "$HOME/git/lumbda/factory/bend-supervisor.sh" "$@" +``` + +## Testing + +Integration tests at `~/git/lumbda/tests/integration/`: +- `test-bash-script-syntax.sh` — `bash -n` lint gate. Catches the apostrophe-in-bash-c class that took the foxhop factory down 24 min on 2026-06-12. +- `test-autoscaler-v2.sh` — V2 reducer covering 7 defect classes (skewed-demand starve, zero-floor reservation, multi-tier greedy, ±25 % damping, cold-start ramp, DLQ surge halve, post-damp CPU ceiling). +- `test-dlq-runner-classify.sh` — DLQ verdict classifier reducer. + +Run: `make -C ~/git/lumbda test-integration`. + +## License + +AGPLv3. Originally developed at foxhop for secp256k1 attack-surface research; shared upstream as obligated by AGPLv3 share-back when the work runs as a service or against shared infrastructure. diff --git a/factory/bend-autoscaler.sh b/factory/bend-autoscaler.sh new file mode 100755 index 0000000..fd16074 --- /dev/null +++ b/factory/bend-autoscaler.sh @@ -0,0 +1,765 @@ +#!/usr/bin/env bash +# bend-autoscaler.sh — bin-pack autopilot for a bend factory. +# +# Watches: +# - .ready / .bin tier distribution on $LUMBDA_QUEUE_DIR +# - live RAM / VRAM headroom on this host +# - current TIER_*_DISPATCH caps (from supervisor.config) +# +# Computes a safe per-tier cap vector that maximizes throughput under a +# memory budget — bin-pack: greedily fill smallest tiers first (highest +# cap, lightest per-dispatch footprint), then ratchet larger tiers until +# predicted RAM/VRAM saturate. +# +# Writes new caps to $LUMBDA_QUEUE_DIR/supervisor.config. Supervisor's +# reload_config picks up our change within $POLL_SECONDS, kills the +# dispatcher, restart loop respawns with new env. No SIGHUP gymnastics. +# +# Tuned for a 24-core / 62 GB RAM / 24 GB VRAM workstation but every +# threshold stays parametric — substrate-grade. +# +# Heartbeat: $LUMBDA_QUEUE_DIR/autoscaler.heartbeat via lib-heartbeat.sh. +# Supervisor restarts us if we go silent. +# +# Exit: +# - SIGTERM/INT +# - $LUMBDA_QUEUE_DIR/AUTOSCALER_STOP marker +# +# Env vars consumed: see $LUMBDA_FACTORY_DIR/CONTRACT.md for our canonical +# table (LUMBDA_QUEUE_DIR, LUMBDA_BACKEND_PROC_PATTERN, AUTOSCALER_V2, +# AUTOSCALER_PEAK_INITIAL, AUTOSCALER_CPU_CEILING, +# AUTOSCALER_DLQ_DAMPING_THRESHOLD, TIER_*_DISPATCH_CEILING, ...). +set -u + +QUEUE_DIR="${LUMBDA_QUEUE_DIR:-${QUEUE_DIR:-/tmp/lumbda-queue}}" +POLL_SECONDS="${AUTOSCALER_POLL:-20}" +LOG="${AUTOSCALER_LOG:-$QUEUE_DIR/autoscaler.log}" +CONFIG_FILE="$QUEUE_DIR/supervisor.config" +STOP_FILE="$QUEUE_DIR/AUTOSCALER_STOP" + +LUMBDA_FACTORY_DIR="${LUMBDA_FACTORY_DIR:-$(dirname "$(readlink -f "$0")")}" +LIB_HEARTBEAT="${LIB_HEARTBEAT:-$LUMBDA_FACTORY_DIR/lib-heartbeat.sh}" +LIB_TIER="${LIB_TIER:-$LUMBDA_FACTORY_DIR/lib-tier.sh}" +# shellcheck source=/dev/null +. "$LIB_HEARTBEAT" +# shellcheck source=/dev/null +. "$LIB_TIER" + +# Backend proc pattern — pgrep -f match for counting in-flight backend forks. +BACKEND_PROC_PATTERN="${LUMBDA_BACKEND_PROC_PATTERN:-bend-cuda}" + +# V1 (legacy) — fixed budget × total knobs. Kept as fallback via AUTOSCALER_V2=0. +RAM_BUDGET_FRACTION="${RAM_BUDGET_FRACTION:-0.70}" +VRAM_BUDGET_FRACTION="${VRAM_BUDGET_FRACTION:-0.85}" +MIN_DISPATCH_PER_TIER="${MIN_DISPATCH_PER_TIER:-1}" + +# ── V2 controller knobs ────────────────────────────────────────── +# V2 replaces V1's "reserve PEAK × allocated SLOT for every tier" model with +# a live-state model: sample actual VRAM free + running backend fork peaks +# + DLQ growth rate, plan = running + headroom_workers. Fall-through +# admission gives single-tier demand the full budget; ±25 % per-poll rate +# damping prevents oscillation; DLQ surge halves a plan next poll. +AUTOSCALER_V2="${AUTOSCALER_V2:-1}" # 1 = V2 live model (default), 0 = V1 fallback +AUTOSCALER_PEAK_INITIAL="${AUTOSCALER_PEAK_INITIAL:-4096}" # MIB per backend fork before first observation +AUTOSCALER_PEAK_MIN="${AUTOSCALER_PEAK_MIN:-2048}" # MIB floor (never under-estimate) +AUTOSCALER_EWMA_ALPHA="${AUTOSCALER_EWMA_ALPHA:-0.3}" # weight of new observation (0.3 = slow decay; max() biased anyway) +AUTOSCALER_CPU_CEILING="${AUTOSCALER_CPU_CEILING:-30}" # never plan > N total workers (24 cores + modest oversub) +AUTOSCALER_RAMP_FROM_ZERO="${AUTOSCALER_RAMP_FROM_ZERO:-4}" # max plan when cur=0 (cold-start step) +AUTOSCALER_DLQ_DAMPING_THRESHOLD="${AUTOSCALER_DLQ_DAMPING_THRESHOLD:-10}" # DLQ entries/poll above which next plan halves +AUTOSCALER_VRAM_SAFETY_RESERVE_MIB="${AUTOSCALER_VRAM_SAFETY_RESERVE_MIB:-2048}" # never plan into last N MIB of free VRAM +# RAM model — V2 originally used VRAM EWMA peak for RAM headroom too. Real +# backend RSS runs 1.5-2× VRAM (lib-tier.sh:48-49 calibration). Separate +# EWMA for RAM peak avoids over-estimating headroom + edging into swap. +AUTOSCALER_RAM_PEAK_INITIAL="${AUTOSCALER_RAM_PEAK_INITIAL:-6400}" # MIB per fork RSS guess pre-observation +AUTOSCALER_RAM_PEAK_MIN="${AUTOSCALER_RAM_PEAK_MIN:-4096}" # MIB floor on RAM/worker estimate +AUTOSCALER_RAM_SAFETY_RESERVE_MIB="${AUTOSCALER_RAM_SAFETY_RESERVE_MIB:-8192}" # leave N MIB unallocated for OS + pool emits +# Swap-pressure signal — fires when MemAvailable falls below this fraction +# of MemTotal OR when SwapUsed grows over poll period. Triggers a halving +# of plan capacity AND writes pool advisory file so emit pool can slow down. +AUTOSCALER_RAM_PRESSURE_FRACTION="${AUTOSCALER_RAM_PRESSURE_FRACTION:-0.15}" # < 15% free MemAvailable = pressure +AUTOSCALER_SWAP_PRESSURE_DELTA_MIB="${AUTOSCALER_SWAP_PRESSURE_DELTA_MIB:-256}" # SwapUsed grew > N MIB in last poll = active swap +# Per-tier hard ceilings — V2 never plans above these regardless of headroom. +# Same shape as lib-tier.sh defaults but explicit so V2 reads them even when +# autoscaler runs against an unchanged supervisor.config. +TIER_MICRO_DISPATCH_CEILING="${TIER_MICRO_DISPATCH_CEILING:-24}" +TIER_SMALL_DISPATCH_CEILING="${TIER_SMALL_DISPATCH_CEILING:-16}" +TIER_MEDIUM_DISPATCH_CEILING="${TIER_MEDIUM_DISPATCH_CEILING:-12}" +TIER_LARGE_DISPATCH_CEILING="${TIER_LARGE_DISPATCH_CEILING:-6}" +# HUGE — solo-dispatch tier. Cap = 1 enforced + V2 drains all other tiers +# before admitting. Largest candidate bins (6-12 GB) land here. +TIER_HUGE_DISPATCH_CEILING="${TIER_HUGE_DISPATCH_CEILING:-1}" + +log() { + local ts msg + ts=$(date +%H:%M:%S) + msg="[$ts] $*" + echo "$msg" | tee -a "$LOG" +} + +# Read host capacity. Returns lines: +# total_ram_mib XXXX +# total_vram_mib YYYY +read_capacity() { + local total_ram_kb total_ram_mib total_vram_mib + total_ram_kb=$(awk '/^MemTotal:/ {print $2}' /proc/meminfo 2>/dev/null || echo 0) + total_ram_mib=$((total_ram_kb / 1024)) + if command -v nvidia-smi >/dev/null 2>&1; then + total_vram_mib=$(nvidia-smi --query-gpu=memory.total --format=csv,noheader,nounits 2>/dev/null | head -1 | tr -dc 0-9) + fi + [ -z "$total_vram_mib" ] && total_vram_mib=0 + printf 'total_ram_mib %d\ntotal_vram_mib %d\n' "$total_ram_mib" "$total_vram_mib" +} + +# Count .ready + .bin files per tier in queue. Single ls + stat per call. +# Emits lines: ready_ N (incl. huge — solo-dispatch tier). +count_ready_by_tier() { + declare -A counts + counts[micro]=0; counts[small]=0; counts[medium]=0; counts[large]=0; counts[huge]=0 + local f tag sz tier + for f in "$QUEUE_DIR"/*.ready "$QUEUE_DIR"/*.bin; do + [ -f "$f" ] || continue + case "$f" in + *.ready) tag=$(basename "$f" .ready) ;; + *.bin) tag=$(basename "$f" .bin) ;; + esac + # De-dup: prefer .bin (covers .ready + .inflight states) + local bin="$QUEUE_DIR/${tag}.bin" + [ -f "$bin" ] || continue + # Skip cells already done/inflight (in-flight handled by tier_inflight) + [ -f "$QUEUE_DIR/${tag}.done" ] && continue + sz=$(stat -c %s "$bin" 2>/dev/null || echo 0) + tier=$(tier_of_size "$sz") + case "$tier" in + micro|small|medium|large|huge) counts[$tier]=$((counts[$tier] + 1)) ;; + esac + done + for t in micro small medium large huge; do + printf 'ready_%s %d\n' "$t" "${counts[$t]}" + done +} + +# Bin-pack: pick per-tier dispatch counts that maximize sum(count_t × value_t) +# under RAM + VRAM budgets. value_t is throughput proxy (assume 1 per dispatch +# slot; weighting by tier's expected wall-time would refine, but uniform-1 is +# a good first cut — our autopilot's job is admission, not perfect throughput). +# +# Greedy: start with all tiers at min, scan small→large. For each tier, +# allocate as many slots as fit AND as demand (ready count) wants AND +# tier's hard ceiling from lib-tier defaults. Stop when budget exhausted. +# +# Outputs four lines: +# plan_micro N +# plan_small N +# plan_medium N +# plan_large N +plan_caps() { + local ram_budget="$1" vram_budget="$2" + local ready_micro="$3" ready_small="$4" ready_medium="$5" ready_large="$6" + local ram_used=0 vram_used=0 + declare -A plan demand cap_max cpu vram + plan[micro]=$MIN_DISPATCH_PER_TIER + plan[small]=$MIN_DISPATCH_PER_TIER + plan[medium]=$MIN_DISPATCH_PER_TIER + plan[large]=$MIN_DISPATCH_PER_TIER + demand[micro]=$ready_micro + demand[small]=$ready_small + demand[medium]=$ready_medium + demand[large]=$ready_large + # cap_max = lib-tier HARD CEILINGS (not the live caps autoscaler just + # wrote). Reading from tier_dispatch would chicken-and-egg: autoscaler + # writes cap=1, next iter reads cap_max=1, can never grow back up + # even when budget freed. Hardcode ceilings here so a planner always + # considers a full feasible range. + cap_max[micro]=24 + cap_max[small]=16 + cap_max[medium]=12 + cap_max[large]=6 + cpu[micro]=$(tier_cpu_mib micro) + cpu[small]=$(tier_cpu_mib small) + cpu[medium]=$(tier_cpu_mib medium) + cpu[large]=$(tier_cpu_mib large) + vram[micro]=$(tier_vram_mib micro) + vram[small]=$(tier_vram_mib small) + vram[medium]=$(tier_vram_mib medium) + vram[large]=$(tier_vram_mib large) + + # Pre-charge minimum-per-tier floor. + local t + for t in micro small medium large; do + ram_used=$((ram_used + plan[$t] * cpu[$t])) + vram_used=$((vram_used + plan[$t] * vram[$t])) + done + + # Greedy fill LARGEST tier first. Smaller tiers drain fast (10-30 s + # per cell) so under-allocating them is cheap; large tiers (200+ s + # per cell) starve catastrophically — at L=1 a 40-cell large queue + # takes ~2 hours to drain. Fill large→medium→small→micro so big + # demand gets priority on VRAM budget; small tiers backfill a + # remainder + still clear quickly. + for t in large medium small micro; do + # Skip tiers with no demand. + [ "${demand[$t]}" -eq 0 ] && continue + local want=$((demand[$t] < cap_max[$t] ? demand[$t] : cap_max[$t])) + while [ "${plan[$t]}" -lt "$want" ]; do + local next_ram=$((ram_used + cpu[$t])) + local next_vram=$((vram_used + vram[$t])) + if [ "$next_ram" -gt "$ram_budget" ] || [ "$next_vram" -gt "$vram_budget" ]; then + break + fi + plan[$t]=$((plan[$t] + 1)) + ram_used=$next_ram + vram_used=$next_vram + done + done + + for t in micro small medium large; do + printf 'plan_%s %d\n' "$t" "${plan[$t]}" + done + printf 'ram_used_mib %d ram_budget_mib %d\n' "$ram_used" "$ram_budget" + printf 'vram_used_mib %d vram_budget_mib %d\n' "$vram_used" "$vram_budget" +} + +# Read current TIER_*_DISPATCH values from supervisor.config (if present). +# Emits: cur_ N +read_current_caps() { + local cur_micro="${TIER_MICRO_DISPATCH:-0}" + local cur_small="${TIER_SMALL_DISPATCH:-0}" + local cur_medium="${TIER_MEDIUM_DISPATCH:-0}" + local cur_large="${TIER_LARGE_DISPATCH:-0}" + local cur_huge="${TIER_HUGE_DISPATCH:-0}" + if [ -f "$CONFIG_FILE" ]; then + # shellcheck source=/dev/null + local v + v=$(grep -E '^TIER_MICRO_DISPATCH=' "$CONFIG_FILE" | tail -1 | cut -d= -f2) + [ -n "$v" ] && cur_micro="$v" + v=$(grep -E '^TIER_SMALL_DISPATCH=' "$CONFIG_FILE" | tail -1 | cut -d= -f2) + [ -n "$v" ] && cur_small="$v" + v=$(grep -E '^TIER_MEDIUM_DISPATCH=' "$CONFIG_FILE" | tail -1 | cut -d= -f2) + [ -n "$v" ] && cur_medium="$v" + v=$(grep -E '^TIER_LARGE_DISPATCH=' "$CONFIG_FILE" | tail -1 | cut -d= -f2) + [ -n "$v" ] && cur_large="$v" + v=$(grep -E '^TIER_HUGE_DISPATCH=' "$CONFIG_FILE" | tail -1 | cut -d= -f2) + [ -n "$v" ] && cur_huge="$v" + fi + printf 'cur_micro %d\ncur_small %d\ncur_medium %d\ncur_large %d\ncur_huge %d\n' \ + "$cur_micro" "$cur_small" "$cur_medium" "$cur_large" "$cur_huge" +} + +# Atomically rewrite supervisor.config preserving non-TIER lines + replacing +# TIER__DISPATCH = plan_. Writes through a tempfile so a partial +# write can't poison a supervisor's source. +write_caps() { + local micro="$1" small="$2" medium="$3" large="$4" huge="$5" + local tmp + tmp="$(mktemp "${CONFIG_FILE}.XXXXXX")" + if [ -f "$CONFIG_FILE" ]; then + grep -vE '^TIER_(MICRO|SMALL|MEDIUM|LARGE|HUGE)_DISPATCH=' "$CONFIG_FILE" > "$tmp" + fi + printf 'TIER_MICRO_DISPATCH=%d\nTIER_SMALL_DISPATCH=%d\nTIER_MEDIUM_DISPATCH=%d\nTIER_LARGE_DISPATCH=%d\nTIER_HUGE_DISPATCH=%d\n' \ + "$micro" "$small" "$medium" "$large" "$huge" >> "$tmp" + mv "$tmp" "$CONFIG_FILE" +} + +# ── V2 controller ──────────────────────────────────────────────── +# All V2 helpers namespaced v2_* so V1 code paths stay readable. + +# v2_sample_live — query current VRAM + backend forks + peak per fork + +# count of in-flight HUGE bins + RAM pressure indicators. +# Emits: +# vram_free_mib N +# ram_free_mib N (MemAvailable in MIB) +# ram_total_mib N (MemTotal in MIB — for pressure fraction calc) +# swap_used_mib N (SwapTotal - SwapFree in MIB) +# running_forks N +# observed_peak_mib N (max VRAM use among running backend forks) +# observed_ram_peak_mib N (max RSS among running backend forks — separate +# from VRAM since RSS = 1.5-2x VRAM typically) +# observed_ram_sum_mib N (sum RSS — used to bound headroom_ram + log) +# inflight_huge N (count of HUGE bins claimed by a dispatcher worker +# but not yet .done) +v2_sample_live() { + local vram_free=0 ram_free_kb=0 ram_free=0 ram_total_kb=0 ram_total=0 + local swap_total_kb=0 swap_free_kb=0 swap_used=0 + local running=0 peak=0 ram_peak=0 ram_sum=0 inflight_huge=0 + if command -v nvidia-smi >/dev/null 2>&1; then + vram_free=$(nvidia-smi --query-gpu=memory.free --format=csv,noheader,nounits 2>/dev/null | head -1 | tr -dc 0-9) + [ -z "$vram_free" ] && vram_free=0 + fi + ram_free_kb=$(awk '/^MemAvailable:/ {print $2}' /proc/meminfo 2>/dev/null || echo 0) + ram_total_kb=$(awk '/^MemTotal:/ {print $2}' /proc/meminfo 2>/dev/null || echo 0) + swap_total_kb=$(awk '/^SwapTotal:/ {print $2}' /proc/meminfo 2>/dev/null || echo 0) + swap_free_kb=$(awk '/^SwapFree:/ {print $2}' /proc/meminfo 2>/dev/null || echo 0) + ram_free=$((ram_free_kb / 1024)) + ram_total=$((ram_total_kb / 1024)) + swap_used=$(( (swap_total_kb - swap_free_kb) / 1024 )) + running=$(pgrep -f "$BACKEND_PROC_PATTERN" 2>/dev/null | wc -l) + if [ "$running" -gt 0 ]; then + # VRAM peak via nvidia-smi + if command -v nvidia-smi >/dev/null 2>&1; then + peak=$(nvidia-smi --query-compute-apps=used_memory --format=csv,noheader,nounits 2>/dev/null \ + | tr -dc '0-9\n' | grep -v '^$' | sort -n | tail -1) + [ -z "$peak" ] && peak=0 + fi + # RAM peak + sum via ps RSS — independent of VRAM since backend RSS + # = ops table + ancilla buffers + CUDA driver context, scales with bin + # size differently than GPU side does. + local rss_list + rss_list=$(pgrep -f "$BACKEND_PROC_PATTERN" 2>/dev/null | xargs -r -I{} ps -o rss= -p {} 2>/dev/null | tr -d ' ') + if [ -n "$rss_list" ]; then + ram_peak=$(echo "$rss_list" | sort -n | tail -1) + ram_peak=$((ram_peak / 1024)) # kB → MIB + ram_sum=$(echo "$rss_list" | awk '{s+=$1} END {print s}') + ram_sum=$((ram_sum / 1024)) + fi + fi + # Count in-flight HUGE bins. + shopt -s nullglob + local f tag bin sz + for f in "$QUEUE_DIR"/*.inflight-*; do + [ ! -f "$f" ] && continue + tag=$(basename "$f" | sed 's/\.inflight-[0-9]*$//') + bin="$QUEUE_DIR/${tag}.bin" + [ ! -f "$bin" ] && continue + sz=$(stat -c %s "$bin" 2>/dev/null || echo 0) + if [ "$sz" -gt "${TIER_LARGE_MAX:-4294967296}" ]; then + inflight_huge=$((inflight_huge + 1)) + fi + done + shopt -u nullglob + printf 'vram_free_mib %d\nram_free_mib %d\nram_total_mib %d\nswap_used_mib %d\nrunning_forks %d\nobserved_peak_mib %d\nobserved_ram_peak_mib %d\nobserved_ram_sum_mib %d\ninflight_huge %d\n' \ + "$vram_free" "$ram_free" "$ram_total" "$swap_used" "$running" "$peak" "$ram_peak" "$ram_sum" "$inflight_huge" +} + +# v2_update_ewma — read prior peak from autoscaler.ewma, fold in new sample. +# Bias up (max) for safety so under-estimate is impossible. Floor at +# AUTOSCALER_PEAK_MIN to avoid runaway shrink when zero forks observed. +# Prints new peak. +v2_update_ewma() { + local observed_peak="$1" + local ewma_file="$QUEUE_DIR/autoscaler.ewma" + local old_peak="$AUTOSCALER_PEAK_INITIAL" + if [ -f "$ewma_file" ]; then + local v + v=$(grep -E '^peak_per_worker_mib=' "$ewma_file" | tail -1 | cut -d= -f2) + [ -n "$v" ] && old_peak="$v" + fi + local new_peak + if [ "$observed_peak" -gt 0 ]; then + new_peak=$(awk -v old="$old_peak" -v obs="$observed_peak" -v a="$AUTOSCALER_EWMA_ALPHA" \ + 'BEGIN { smoothed = old*(1-a) + obs*a; + if (obs > smoothed) smoothed = obs; + printf "%d", smoothed }') + else + new_peak="$old_peak" + fi + [ "$new_peak" -lt "$AUTOSCALER_PEAK_MIN" ] && new_peak="$AUTOSCALER_PEAK_MIN" + { + echo "peak_per_worker_mib=$new_peak" + echo "last_updated=$(date -u +%FT%TZ)" + echo "last_observed_mib=$observed_peak" + } > "$ewma_file" + echo "$new_peak" +} + +# v2_update_ram_ewma — same shape as v2_update_ewma but for RAM peak. +# Separate file (autoscaler.ram-ewma) so VRAM + RAM tracks stay independent. +v2_update_ram_ewma() { + local observed_peak="$1" + local ewma_file="$QUEUE_DIR/autoscaler.ram-ewma" + local old_peak="$AUTOSCALER_RAM_PEAK_INITIAL" + if [ -f "$ewma_file" ]; then + local v + v=$(grep -E '^ram_peak_per_worker_mib=' "$ewma_file" | tail -1 | cut -d= -f2) + [ -n "$v" ] && old_peak="$v" + fi + local new_peak + if [ "$observed_peak" -gt 0 ]; then + new_peak=$(awk -v old="$old_peak" -v obs="$observed_peak" -v a="$AUTOSCALER_EWMA_ALPHA" \ + 'BEGIN { smoothed = old*(1-a) + obs*a; + if (obs > smoothed) smoothed = obs; + printf "%d", smoothed }') + else + new_peak="$old_peak" + fi + [ "$new_peak" -lt "$AUTOSCALER_RAM_PEAK_MIN" ] && new_peak="$AUTOSCALER_RAM_PEAK_MIN" + { + echo "ram_peak_per_worker_mib=$new_peak" + echo "last_updated=$(date -u +%FT%TZ)" + echo "last_observed_mib=$observed_peak" + } > "$ewma_file" + echo "$new_peak" +} + +# v2_swap_pressure — read prior swap_used from autoscaler.swap-state, +# diff against current. Returns 1 if SwapUsed grew > threshold MIB in +# last poll, else 0. State file rewritten each call. +v2_swap_pressure() { + local cur_swap_used="$1" + local state="$QUEUE_DIR/autoscaler.swap-state" + local prev_swap=0 + if [ -f "$state" ]; then + prev_swap=$(grep -E '^swap_used_mib=' "$state" | tail -1 | cut -d= -f2) + [ -z "$prev_swap" ] && prev_swap=0 + fi + local delta=$((cur_swap_used - prev_swap)) + echo "swap_used_mib=$cur_swap_used" > "$state" + if [ "$delta" -gt "$AUTOSCALER_SWAP_PRESSURE_DELTA_MIB" ]; then + echo 1 + else + echo 0 + fi +} + +# v2_write_pool_advisory — emit advisory file the pool reads each iter. +# Format: KEY=VALUE lines. Pool can act on: +# slow_emit=1|0 — when 1, pool should reduce concurrent emits +# reason=ram_pressure|swap_active|none +v2_write_pool_advisory() { + local slow="$1" reason="$2" + { + echo "# bend-autoscaler advisory — last update $(date -u +%FT%TZ)" + echo "slow_emit=$slow" + echo "reason=$reason" + } > "$QUEUE_DIR/emit.advisory" +} + +# v2_dlq_growth — count DLQ reason files mtime'd in last $1 seconds. +# Used as oversubscription signal: spike in DLQ → halve next plan. +v2_dlq_growth() { + local poll="$1" + local mins=$((poll / 60 + 1)) + find "$QUEUE_DIR/dlq" -maxdepth 1 -type f -name '*.reason' -mmin -"$mins" 2>/dev/null | wc -l +} + +# v2_damp_change — limit per-tier rate of change to ±25 % per poll. +# Cold start (cur=0) ramps up to AUTOSCALER_RAMP_FROM_ZERO in one step. +v2_damp_change() { + local cur="$1" plan="$2" + if [ "$cur" = "0" ]; then + if [ "$plan" -gt "$AUTOSCALER_RAMP_FROM_ZERO" ]; then + echo "$AUTOSCALER_RAMP_FROM_ZERO" + else + echo "$plan" + fi + return + fi + local max_step=$((cur / 4)) + [ "$max_step" -lt 1 ] && max_step=1 + if [ "$plan" -gt "$cur" ]; then + local up=$((cur + max_step)) + [ "$plan" -gt "$up" ] && plan="$up" + elif [ "$plan" -lt "$cur" ]; then + local dn=$((cur - max_step)) + [ "$plan" -lt "$dn" ] && plan="$dn" + fi + echo "$plan" +} + +# v2_plan_caps — live-state planner. +# Args (positional): +# 1 vram_free_mib 2 ram_free_mib 3..7 ready_micro/small/medium/large/huge +# 8..12 cur_micro/small/medium/large/huge 13 peak_per_worker_mib +# 14 running_forks 15 dlq_growth 16 inflight_huge +# 17 ram_peak_per_worker_mib 18 ram_total_mib 19 swap_pressure +# Emits plan_ N + diagnostics (headroom_workers, total_budget, dlq_damped, +# huge_active, ram_damped — 1 when RAM pressure halved plan). +v2_plan_caps() { + local vram_free="$1" ram_free="$2" + local r_micro="$3" r_small="$4" r_medium="$5" r_large="$6" r_huge="$7" + local c_micro="$8" c_small="$9" c_medium="${10}" c_large="${11}" c_huge="${12}" + local peak="${13}" running="${14}" dlq_growth="${15}" inflight_huge="${16:-0}" + local ram_peak="${17:-$peak}" ram_total="${18:-0}" swap_pressure="${19:-0}" + + # Headroom workers from VRAM. Safety reserve protects against bursty + # forks landing all at once + saturating GPU mid-poll-period. + local vram_after_reserve=$((vram_free - AUTOSCALER_VRAM_SAFETY_RESERVE_MIB)) + [ "$vram_after_reserve" -lt 0 ] && vram_after_reserve=0 + local headroom_vram=$((vram_after_reserve / peak)) + # RAM bound — backend RSS = 1.5-2× VRAM typically (lib-tier.sh:48-49). + # Use SEPARATE ram_peak EWMA + ram_safety_reserve so headroom_ram stays + # honest. Old code shared VRAM peak which OVER-estimated RAM headroom + # + edged into swap on heavy sweep loads. + local ram_after_reserve=$((ram_free - AUTOSCALER_RAM_SAFETY_RESERVE_MIB)) + [ "$ram_after_reserve" -lt 0 ] && ram_after_reserve=0 + local headroom_ram=$((ram_after_reserve / ram_peak)) + local headroom=$headroom_vram + [ "$headroom_ram" -lt "$headroom" ] && headroom=$headroom_ram + + # Total budget = workers we COULD have, given current load + headroom. + local total_budget=$((running + headroom)) + # Cap at CPU ceiling (24 cores + modest oversub). + [ "$total_budget" -gt "$AUTOSCALER_CPU_CEILING" ] && total_budget=$AUTOSCALER_CPU_CEILING + + # RAM-pressure damping — fires when MemAvailable < AUTOSCALER_RAM_PRESSURE_FRACTION + # of total OR active swap (SwapUsed grew > delta MIB last poll). Either + # signal means we sit at swap edge; halving total_budget reduces new + # admissions so running workers can drain + RAM recovers before swap thrash. + local ram_damped=0 + local ram_pressure_threshold=$((ram_total * 15 / 100)) # 15% default; matches RAM_PRESSURE_FRACTION + if [ "$ram_total" -gt 0 ] && [ "$ram_free" -lt "$ram_pressure_threshold" ]; then + total_budget=$((total_budget / 2)) + ram_damped=1 + fi + if [ "$swap_pressure" -eq 1 ]; then + total_budget=$((total_budget / 2)) + ram_damped=1 + fi + + # DLQ damping — surge of DLQ entries means we already over-subscribed + # OR we have a bad-cell batch. Either way, halving caps next poll + # protects against amplification while operator triages. + local dlq_damped=0 + if [ "$dlq_growth" -gt "$AUTOSCALER_DLQ_DAMPING_THRESHOLD" ]; then + total_budget=$((total_budget / 2)) + dlq_damped=1 + fi + + # HUGE solo-dispatch branch — must run before normal planning. Triggers: + # (a) r_huge>0 : huge bin queued, waiting for card to drain. + # (b) inflight_huge>0 : a huge already claimed by a dispatcher, still + # executing. Other tiers must stay starved until + # dispatcher releases this slot. + # cur_huge alone is NOT a trigger — stale supervisor.config can hold + # TIER_HUGE_DISPATCH=1 indefinitely with no bin actually running. + local plan_micro=0 plan_small=0 plan_medium=0 plan_large=0 plan_huge=0 + local huge_active=0 + if [ "$r_huge" -gt 0 ] || [ "$inflight_huge" -gt 0 ]; then + huge_active=1 + # Card-empty? Admit huge. "card-empty" signal is running=0 + # OR inflight_huge>0 (huge already running counts as "card claimed + # by huge, keep slot open for it to continue"). + if [ "$running" -eq 0 ] || [ "$inflight_huge" -gt 0 ]; then + plan_huge="$TIER_HUGE_DISPATCH_CEILING" + fi + # plan_others stays at 0 regardless — drain mode. Damping at the + # tail rate-limits descent so already-running cells finish + # naturally without abrupt kill. + # Emit + return — skip normal multi-tier planning. + plan_micro=$(v2_damp_change "$c_micro" "$plan_micro") + plan_small=$(v2_damp_change "$c_small" "$plan_small") + plan_medium=$(v2_damp_change "$c_medium" "$plan_medium") + plan_large=$(v2_damp_change "$c_large" "$plan_large") + plan_huge=$(v2_damp_change "$c_huge" "$plan_huge") + printf 'plan_micro %d\nplan_small %d\nplan_medium %d\nplan_large %d\nplan_huge %d\n' \ + "$plan_micro" "$plan_small" "$plan_medium" "$plan_large" "$plan_huge" + printf 'headroom_workers %d running_forks %d total_budget %d peak_per_worker_mib %d ram_peak_mib %d dlq_damped %d ram_damped %d huge_active %d\n' \ + "$headroom" "$running" "$total_budget" "$peak" "$ram_peak" "$dlq_damped" "$ram_damped" "$huge_active" + return + fi + + # Tier demand sentinels — V2 zero-floor (V1 forced MIN=1 even on empty). + local nonzero=0 + [ "$r_micro" -gt 0 ] && nonzero=$((nonzero + 1)) + [ "$r_small" -gt 0 ] && nonzero=$((nonzero + 1)) + [ "$r_medium" -gt 0 ] && nonzero=$((nonzero + 1)) + [ "$r_large" -gt 0 ] && nonzero=$((nonzero + 1)) + + if [ "$nonzero" -le 1 ]; then + # Single-tier (or no-demand) — grant full budget to one tier + # with work. Capped at that tier's ceiling. + if [ "$r_large" -gt 0 ]; then + plan_large=$((total_budget < TIER_LARGE_DISPATCH_CEILING ? total_budget : TIER_LARGE_DISPATCH_CEILING)) + elif [ "$r_medium" -gt 0 ]; then + plan_medium=$((total_budget < TIER_MEDIUM_DISPATCH_CEILING ? total_budget : TIER_MEDIUM_DISPATCH_CEILING)) + elif [ "$r_small" -gt 0 ]; then + plan_small=$((total_budget < TIER_SMALL_DISPATCH_CEILING ? total_budget : TIER_SMALL_DISPATCH_CEILING)) + elif [ "$r_micro" -gt 0 ]; then + plan_micro=$((total_budget < TIER_MICRO_DISPATCH_CEILING ? total_budget : TIER_MICRO_DISPATCH_CEILING)) + fi + else + # Multi-tier — MIN=1 to each tier with demand, then greedy fill + # largest-tier-first (slow drains get priority on capacity). + local remaining=$total_budget + [ "$r_large" -gt 0 ] && [ "$remaining" -gt 0 ] && { plan_large=1; remaining=$((remaining - 1)); } + [ "$r_medium" -gt 0 ] && [ "$remaining" -gt 0 ] && { plan_medium=1; remaining=$((remaining - 1)); } + [ "$r_small" -gt 0 ] && [ "$remaining" -gt 0 ] && { plan_small=1; remaining=$((remaining - 1)); } + [ "$r_micro" -gt 0 ] && [ "$remaining" -gt 0 ] && { plan_micro=1; remaining=$((remaining - 1)); } + # Greedy: largest tier with demand and below ceiling consumes 1 slot per pass. + while [ "$remaining" -gt 0 ]; do + local advanced=0 + if [ "$plan_large" -lt "$TIER_LARGE_DISPATCH_CEILING" ] && [ "$r_large" -gt "$plan_large" ]; then + plan_large=$((plan_large + 1)); remaining=$((remaining - 1)); advanced=1 + [ "$remaining" -eq 0 ] && break + fi + if [ "$plan_medium" -lt "$TIER_MEDIUM_DISPATCH_CEILING" ] && [ "$r_medium" -gt "$plan_medium" ]; then + plan_medium=$((plan_medium + 1)); remaining=$((remaining - 1)); advanced=1 + [ "$remaining" -eq 0 ] && break + fi + if [ "$plan_small" -lt "$TIER_SMALL_DISPATCH_CEILING" ] && [ "$r_small" -gt "$plan_small" ]; then + plan_small=$((plan_small + 1)); remaining=$((remaining - 1)); advanced=1 + [ "$remaining" -eq 0 ] && break + fi + if [ "$plan_micro" -lt "$TIER_MICRO_DISPATCH_CEILING" ] && [ "$r_micro" -gt "$plan_micro" ]; then + plan_micro=$((plan_micro + 1)); remaining=$((remaining - 1)); advanced=1 + [ "$remaining" -eq 0 ] && break + fi + [ "$advanced" -eq 0 ] && break + done + fi + + # Rate-of-change damping — ±25 % per poll. Prevents oscillation when + # demand or VRAM headroom stays bouncy. + plan_micro=$(v2_damp_change "$c_micro" "$plan_micro") + plan_small=$(v2_damp_change "$c_small" "$plan_small") + plan_medium=$(v2_damp_change "$c_medium" "$plan_medium") + plan_large=$(v2_damp_change "$c_large" "$plan_large") + + # Post-damp CPU ceiling — damping toward a HIGHER cur can keep total + # above ceiling. Trim largest tiers first (cheapest to lose a slot at + # slow-drain end). Repeat until within budget. + plan_sum=$((plan_micro + plan_small + plan_medium + plan_large)) + while [ "$plan_sum" -gt "$AUTOSCALER_CPU_CEILING" ]; do + if [ "$plan_large" -gt 0 ]; then plan_large=$((plan_large - 1)) + elif [ "$plan_medium" -gt 0 ]; then plan_medium=$((plan_medium - 1)) + elif [ "$plan_small" -gt 0 ]; then plan_small=$((plan_small - 1)) + elif [ "$plan_micro" -gt 0 ]; then plan_micro=$((plan_micro - 1)) + else break + fi + plan_sum=$((plan_micro + plan_small + plan_medium + plan_large)) + done + + # plan_huge always 0 in non-huge branch (handled above + returned early). + printf 'plan_micro %d\nplan_small %d\nplan_medium %d\nplan_large %d\nplan_huge %d\n' \ + "$plan_micro" "$plan_small" "$plan_medium" "$plan_large" 0 + printf 'headroom_workers %d running_forks %d total_budget %d peak_per_worker_mib %d ram_peak_mib %d dlq_damped %d ram_damped %d huge_active %d\n' \ + "$headroom" "$running" "$total_budget" "$peak" "$ram_peak" "$dlq_damped" "$ram_damped" "$huge_active" +} + +# ── exit handlers ──────────────────────────────────────────────── +EXIT_REASON="" +on_exit() { + local r="${EXIT_REASON:-unknown-exit}" + heartbeat_exit_cause "$QUEUE_DIR" "autoscaler" "$r" + echo "[$(date +%H:%M:%S)] bend-autoscaler exit reason=$r" | tee -a "$LOG" +} +trap on_exit EXIT +trap 'EXIT_REASON=signal-int; exit 130' INT +trap 'EXIT_REASON=signal-term; exit 143' TERM + +log "bend-autoscaler start queue=$QUEUE_DIR poll=${POLL_SECONDS}s v2=$AUTOSCALER_V2" +if [ "$AUTOSCALER_V2" = "1" ]; then + log " V2 live model — peak_init=${AUTOSCALER_PEAK_INITIAL}MIB cpu_ceiling=$AUTOSCALER_CPU_CEILING dlq_threshold=$AUTOSCALER_DLQ_DAMPING_THRESHOLD" +else + log " V1 fixed-budget — RAM frac=$RAM_BUDGET_FRACTION VRAM frac=$VRAM_BUDGET_FRACTION" +fi + +# Cold-recovery baseline — persist KNOWN-GOOD caps so a cold restart of +# every component (autoscaler crash + supervisor restart with stale +# config) can fall back to a safe operating point. Written each poll +# after a successful plan. +BASELINE_FILE="$QUEUE_DIR/supervisor.config.baseline" + +while true; do + heartbeat_touch "$QUEUE_DIR" "autoscaler" + if [ -f "$STOP_FILE" ]; then + log "STOP marker — exiting" + rm -f "$STOP_FILE" + EXIT_REASON="stop-marker" + break + fi + + ready_out=$(count_ready_by_tier) + ready_micro=$(echo "$ready_out" | awk '/^ready_micro/ {print $2}') + ready_small=$(echo "$ready_out" | awk '/^ready_small/ {print $2}') + ready_medium=$(echo "$ready_out" | awk '/^ready_medium/ {print $2}') + ready_large=$(echo "$ready_out" | awk '/^ready_large/ {print $2}') + ready_huge=$(echo "$ready_out" | awk '/^ready_huge/ {print $2}') + total_ready=$((ready_micro + ready_small + ready_medium + ready_large + ready_huge)) + + cur_out=$(read_current_caps) + cur_micro=$(echo "$cur_out" | awk '/^cur_micro/ {print $2}') + cur_small=$(echo "$cur_out" | awk '/^cur_small/ {print $2}') + cur_medium=$(echo "$cur_out" | awk '/^cur_medium/ {print $2}') + cur_large=$(echo "$cur_out" | awk '/^cur_large/ {print $2}') + cur_huge=$(echo "$cur_out" | awk '/^cur_huge/ {print $2}') + + if [ "$AUTOSCALER_V2" = "1" ]; then + live_out=$(v2_sample_live) + vram_free_mib=$(echo "$live_out" | awk '/^vram_free_mib/ {print $2}') + ram_free_mib=$(echo "$live_out" | awk '/^ram_free_mib/ {print $2}') + ram_total_mib=$(echo "$live_out" | awk '/^ram_total_mib/ {print $2}') + swap_used_mib=$(echo "$live_out" | awk '/^swap_used_mib/ {print $2}') + running_forks=$(echo "$live_out" | awk '/^running_forks/ {print $2}') + observed_peak_mib=$(echo "$live_out" | awk '/^observed_peak_mib/ {print $2}') + observed_ram_peak_mib=$(echo "$live_out" | awk '/^observed_ram_peak_mib/ {print $2}') + inflight_huge=$(echo "$live_out" | awk '/^inflight_huge/ {print $2}') + peak_per_worker_mib=$(v2_update_ewma "$observed_peak_mib") + ram_peak_per_worker_mib=$(v2_update_ram_ewma "$observed_ram_peak_mib") + dlq_growth=$(v2_dlq_growth "$POLL_SECONDS") + swap_pressure=$(v2_swap_pressure "$swap_used_mib") + + plan_out=$(v2_plan_caps \ + "$vram_free_mib" "$ram_free_mib" \ + "$ready_micro" "$ready_small" "$ready_medium" "$ready_large" "$ready_huge" \ + "$cur_micro" "$cur_small" "$cur_medium" "$cur_large" "$cur_huge" \ + "$peak_per_worker_mib" "$running_forks" "$dlq_growth" "$inflight_huge" \ + "$ram_peak_per_worker_mib" "$ram_total_mib" "$swap_pressure") + # Write pool advisory based on planner verdict — pool reads each iter. + # ram_damped emitted by planner; reuse as advisory trigger. + ram_pressure_active=$(echo "$plan_out" | awk 'match($0, /ram_damped [0-9]+/) {print substr($0, RSTART+11, RLENGTH-11)}') + if [ "${ram_pressure_active:-0}" -eq 1 ]; then + reason="ram_pressure" + [ "$swap_pressure" -eq 1 ] && reason="swap_active" + v2_write_pool_advisory 1 "$reason" + else + v2_write_pool_advisory 0 "none" + fi + diag=$(echo "$plan_out" | grep -E '^headroom_workers') + else + cap_out=$(read_capacity) + total_ram_mib=$(echo "$cap_out" | awk '/^total_ram_mib/ {print $2}') + total_vram_mib=$(echo "$cap_out" | awk '/^total_vram_mib/ {print $2}') + ram_budget=$(awk -v t="$total_ram_mib" -v f="$RAM_BUDGET_FRACTION" 'BEGIN{printf "%d", t*f}') + vram_budget=$(awk -v t="$total_vram_mib" -v f="$VRAM_BUDGET_FRACTION" 'BEGIN{printf "%d", t*f}') + plan_out=$(plan_caps "$ram_budget" "$vram_budget" \ + "$ready_micro" "$ready_small" "$ready_medium" "$ready_large") + diag="" + fi + + plan_micro=$(echo "$plan_out" | awk '/^plan_micro/ {print $2}') + plan_small=$(echo "$plan_out" | awk '/^plan_small/ {print $2}') + plan_medium=$(echo "$plan_out" | awk '/^plan_medium/ {print $2}') + plan_large=$(echo "$plan_out" | awk '/^plan_large/ {print $2}') + # V1 doesn't emit plan_huge — treat as zero so write_caps still gets 5 args. + plan_huge=$(echo "$plan_out" | awk '/^plan_huge/ {print $2}') + [ -z "$plan_huge" ] && plan_huge=0 + + # Plan-change log — fires only on a transition. Operators read this to + # see "what caused this dispatch shift". + if [ "$cur_micro" != "$plan_micro" ] || [ "$cur_small" != "$plan_small" ] || \ + [ "$cur_medium" != "$plan_medium" ] || [ "$cur_large" != "$plan_large" ] || \ + [ "$cur_huge" != "$plan_huge" ]; then + if [ -n "$diag" ]; then + log "ready=$total_ready (μ$ready_micro s$ready_small m$ready_medium L$ready_large H$ready_huge) cur=(μ$cur_micro s$cur_small m$cur_medium L$cur_large H$cur_huge) -> plan=(μ$plan_micro s$plan_small m$plan_medium L$plan_large H$plan_huge) $diag" + else + log "ready=$total_ready (μ$ready_micro s$ready_small m$ready_medium L$ready_large H$ready_huge) cur=(μ$cur_micro s$cur_small m$cur_medium L$cur_large H$cur_huge) -> plan=(μ$plan_micro s$plan_small m$plan_medium L$plan_large H$plan_huge)" + fi + write_caps "$plan_micro" "$plan_small" "$plan_medium" "$plan_large" "$plan_huge" + else + # Stable-plan heartbeat — fires every AUTOSCALER_STABLE_HEARTBEAT_POLLS + # polls (default 6 = 2 min at poll=20s) when plan does NOT change. + # Without this, a long drain phase produces no log output, making + # the autoscaler look frozen to operators reading autoscaler.log + # while it actually polls silently. + STABLE_POLLS=$((${STABLE_POLLS:-0} + 1)) + if [ "$STABLE_POLLS" -ge "${AUTOSCALER_STABLE_HEARTBEAT_POLLS:-6}" ]; then + log "STABLE plan=(μ$plan_micro s$plan_small m$plan_medium L$plan_large H$plan_huge) $diag" + STABLE_POLLS=0 + fi + fi + + # Persist baseline for cold-recovery — only when plan looks healthy + # (total >= AUTOSCALER_CPU_CEILING/4 to filter throttled states). + # HUGE counts toward total though its cap stays solo-1. + plan_total=$((plan_micro + plan_small + plan_medium + plan_large + plan_huge)) + if [ "$plan_total" -ge $((AUTOSCALER_CPU_CEILING / 4)) ]; then + { + echo "# bend-autoscaler last-known-good caps — written $(date -u +%FT%TZ)" + echo "# Source for cold recovery: supervisor falls back to this on autoscaler stall." + printf 'TIER_MICRO_DISPATCH=%d\nTIER_SMALL_DISPATCH=%d\nTIER_MEDIUM_DISPATCH=%d\nTIER_LARGE_DISPATCH=%d\nTIER_HUGE_DISPATCH=%d\n' \ + "$plan_micro" "$plan_small" "$plan_medium" "$plan_large" "$plan_huge" + } > "$BASELINE_FILE" + fi + + sleep "$POLL_SECONDS" +done diff --git a/factory/bend-dispatcher.sh b/factory/bend-dispatcher.sh new file mode 100755 index 0000000..a862896 --- /dev/null +++ b/factory/bend-dispatcher.sh @@ -0,0 +1,192 @@ +#!/usr/bin/env bash +# bend-dispatcher.sh — singleton dispatcher for a circuit-emission pipeline. +# +# Polls $LUMBDA_QUEUE_DIR/*.ready, dispatches each via $LUMBDA_BACKEND_CMD +# (or a custom bend-dispatch.py wrapper named in BEND_DISPATCH), logs result +# to $RESULTS_TSV, removes .bin to free disk, touches .done. +# +# Singleton: refuses to start if another instance holds +# $LUMBDA_QUEUE_DIR/dispatcher.lock. +# +# Exits when no .ready remains AND no .emitting marker AND $LUMBDA_QUEUE_DIR/STOP +# exists, OR after MAX_IDLE_LOOPS (default 60 = 5 min) of empty polling. +# +# Usage: bend-dispatcher.sh [QUEUE_DIR [RESULTS_TSV [BATCHES]]] +# QUEUE_DIR default $LUMBDA_QUEUE_DIR +# RESULTS_TSV default $QUEUE_DIR/results.tsv +# BATCHES default 141 +# +# Self-identifies as "bend-dispatcher" in cmdline for precise pkill targeting. +# +# Results TSV row format: +# tag n_ops qubits avg_tof score status identity wall_s +# config_root ops_hash trace_hash score_hash candidate_merkle_root +# Old readers ignore unknown trailing columns. Pre-fingerprint rows have +# these columns empty when migrated. +# +# Env vars consumed: see $LUMBDA_FACTORY_DIR/CONTRACT.md (LUMBDA_QUEUE_DIR, +# LUMBDA_BACKEND_CMD, LUMBDA_DOMAIN_DIR, BEND_DISPATCH, HASHES_PY). +set -u + +QUEUE_DIR="${1:-${LUMBDA_QUEUE_DIR:-/tmp/lumbda-queue}}" +RESULTS_TSV="${2:-$QUEUE_DIR/results.tsv}" +BATCHES="${3:-141}" +MAX_IDLE_LOOPS="${MAX_IDLE_LOOPS:-60}" + +# BEND_DISPATCH = python wrapper that talks to backend over a portal. +# When unset, consumer should set it via env (foxhop sets to +# $LUMBDA_DOMAIN_DIR/runs/lumbda-sweep-008/bend-dispatch.py). +# HASHES_PY = optional fingerprint helper; falls through to empty columns +# when missing. +LUMBDA_DOMAIN_DIR="${LUMBDA_DOMAIN_DIR:-}" +BEND_DISPATCH="${BEND_DISPATCH:-${LUMBDA_DOMAIN_DIR:+$LUMBDA_DOMAIN_DIR/runs/lumbda-sweep-008/bend-dispatch.py}}" +HASHES_PY="${HASHES_PY:-${LUMBDA_DOMAIN_DIR:+$LUMBDA_DOMAIN_DIR/scripts/ecdsa-hashes.py}}" + +mkdir -p "$QUEUE_DIR" +LOCK="$QUEUE_DIR/dispatcher.lock" + +echo $$ > "$QUEUE_DIR/dispatcher.pid" +trap 'rm -f "$QUEUE_DIR/dispatcher.pid"' EXIT + +exec -a bend-dispatcher bash -c ' +QUEUE_DIR="'"$QUEUE_DIR"'" +RESULTS_TSV="'"$RESULTS_TSV"'" +BATCHES="'"$BATCHES"'" +MAX_IDLE_LOOPS="'"$MAX_IDLE_LOOPS"'" +BEND_DISPATCH="'"$BEND_DISPATCH"'" +HASHES_PY="'"$HASHES_PY"'" +LOCK="'"$LOCK"'" + +# Singleton via flock +exec 9>"$LOCK" +if ! flock -n 9; then + echo "[$(date +%H:%M:%S)] bend-dispatcher: another instance holds $LOCK, refusing to start" + exit 1 +fi +echo "[$(date +%H:%M:%S)] bend-dispatcher start queue=$QUEUE_DIR" +trap "echo \"[\$(date +%H:%M:%S)] bend-dispatcher exit\"; rm -f $LOCK" EXIT + +# Header includes fingerprint columns. A fresh results.tsv gets the full +# 13-column header. A pre-fingerprint file with only the original 8 columns +# stays untouched (so readers keyed off the legacy header keep working) but +# every new row gets fingerprints appended after legacy fields. +if [ ! -f "$RESULTS_TSV" ]; then + printf "tag\tn_ops\tqubits\tavg_tof\tscore\tstatus\tidentity\twall_s\tconfig_root\tops_hash\ttrace_hash\tscore_hash\tcandidate_merkle_root\n" > "$RESULTS_TSV" +fi + +idle=0 +while true; do + ready=$(ls "$QUEUE_DIR"/*.ready 2>/dev/null | sort | head -1) + if [ -z "$ready" ]; then + # check stop conditions + if [ -f "$QUEUE_DIR/STOP" ]; then + n_emitting=$(ls "$QUEUE_DIR"/*.emitting 2>/dev/null | wc -l) + [ "$n_emitting" = "0" ] && { echo "[$(date +%H:%M:%S)] STOP + no emits"; break; } + fi + idle=$((idle + 1)) + if [ "$idle" -ge "$MAX_IDLE_LOOPS" ]; then + # nothing in flight, no ready, no new emits coming + n_emitting=$(ls "$QUEUE_DIR"/*.emitting 2>/dev/null | wc -l) + pending=$(ls "$QUEUE_DIR"/*.lsp 2>/dev/null | wc -l) + n_done=$(ls "$QUEUE_DIR"/*.done 2>/dev/null | wc -l) + n_ready_total=$((pending - n_done)) + if [ "$n_emitting" = "0" ] && [ "$n_ready_total" -le "0" ]; then + echo "[$(date +%H:%M:%S)] idle drained" + break + fi + idle=0 + fi + sleep 5 + continue + fi + idle=0 + tag=$(basename "$ready" .ready) + bin="$QUEUE_DIR/${tag}.bin" + if [ ! -f "$bin" ]; then + echo "[$(date +%H:%M:%S)] SKIP $tag bin missing" + rm -f "$ready" + touch "$QUEUE_DIR/${tag}.done" + continue + fi + echo "[$(date +%H:%M:%S)] dispatch $tag ($(du -h $bin | cut -f1))" + t0=$(date +%s) + out=$(python3 "$BEND_DISPATCH" "$bin" "$BATCHES" 2>&1) + t1=$(date +%s) + wall=$((t1 - t0)) + + # Dead-letter detection: dispatch returned non-parseable output (backend + # crashed or empty response). Move bin + ready to DLQ for retry by + # watchdog after backend comes back up. We dont mark .done here so the + # cell stays out of completed state — only DLQ retries fully drain it. + if ! echo "$out" | grep -q "^score = "; then + mkdir -p "$QUEUE_DIR/dlq" + retries=0 + if [ -f "$QUEUE_DIR/dlq/${tag}.retries" ]; then + retries=$(cat "$QUEUE_DIR/dlq/${tag}.retries") + fi + retries=$((retries + 1)) + echo "[$(date +%H:%M:%S)] DLQ $tag (retry=$retries, wall=${wall}s, backend likely down)" + echo "$out" | tail -10 > "$QUEUE_DIR/dlq/${tag}.reason" + echo "$retries" > "$QUEUE_DIR/dlq/${tag}.retries" + if [ "$retries" -lt 5 ]; then + mv "$bin" "$QUEUE_DIR/dlq/${tag}.bin" + rm -f "$ready" + # Note: do NOT touch .done — cell still pending. Watchdog/reaper + # moves bin back + re-touches .ready after backend stays healthy 60s+. + else + echo "[$(date +%H:%M:%S)] DLQ $tag exhausted retries — marking .done.fail" + rm -f "$bin" "$ready" + touch "$QUEUE_DIR/${tag}.done.fail" + touch "$QUEUE_DIR/${tag}.done" + fi + continue + fi + # Keep last 5 lines: parsed= + score + trace_hash= + raw_portal_resp= + + # trailing newline. Portal-resp blob lets us recompute fingerprints + # offline if dispatcher TSV ever needs re-hashing. + echo "$out" | tail -5 > "$QUEUE_DIR/${tag}.dispatch.log" + nops=$(echo "$out" | grep -oP "n_ops.: \K[0-9]+" | head -1) + qubits=$(echo "$out" | grep -oP "qubits.: \K[0-9]+" | head -1) + tof=$(echo "$out" | grep -oP "avg_tof.: \K[0-9.]+" | head -1) + score=$(echo "$out" | grep -oP "score = .* = \K\S+") + status=$(echo "$out" | grep -oP "status.: .\K[A-Z]+" | head -1) + ident=$(echo "$out" | grep -oP "identity.: .\K[a-z]+" | head -1) + + # ── Fingerprint columns ───────────────────────────────────────────── + # cell .lsp drives config_root. Cells get staged into queue dir as + # $QUEUE_DIR/${tag}.lsp by the feeder. When originating .lsp is absent + # (e.g. probe path), config_root falls through to all-zero digest and + # downstream readers can detect absence. + cell="$QUEUE_DIR/${tag}.lsp" + portal_resp=$(echo "$out" | grep -oP "^raw_portal_resp=\K.*" | tail -1) + # Pipe portal response into HASHES_PY so every root and the + # candidate_merkle_root land in a single JSON line. When HASHES_PY is + # unset / missing, fall through with empty columns so legacy callers + # still get the score row. + score_json=$(printf "{\"tag\":\"%s\",\"n_ops\":\"%s\",\"qubits\":\"%s\",\"avg_tof\":\"%s\",\"score\":\"%s\",\"status\":\"%s\",\"identity\":\"%s\",\"wall_s\":\"%s\"}" \ + "$tag" "${nops:-}" "${qubits:-}" "${tof:-}" "${score:-}" "${status:-}" "${ident:-}" "$wall") + hash_json="{}" + if [ -n "$HASHES_PY" ] && [ -f "$HASHES_PY" ]; then + hash_json=$(printf "%s" "$portal_resp" | \ + python3 "$HASHES_PY" all \ + --cell "$cell" \ + --bin "$bin" \ + --portal-stdin \ + --score-json "$score_json" 2>/dev/null || echo "{}") + fi + config_root=$(echo "$hash_json" | python3 -c "import sys,json; d=json.load(sys.stdin); print(d.get(\"config_root\",\"\"))" 2>/dev/null) + ops_hash=$(echo "$hash_json" | python3 -c "import sys,json; d=json.load(sys.stdin); print(d.get(\"ops_hash\",\"\"))" 2>/dev/null) + trace_hash=$(echo "$hash_json" | python3 -c "import sys,json; d=json.load(sys.stdin); print(d.get(\"trace_hash\",\"\"))" 2>/dev/null) + score_hash=$(echo "$hash_json" | python3 -c "import sys,json; d=json.load(sys.stdin); print(d.get(\"score_hash\",\"\"))" 2>/dev/null) + merkle=$(echo "$hash_json" | python3 -c "import sys,json; d=json.load(sys.stdin); print(d.get(\"candidate_merkle_root\",\"\"))" 2>/dev/null) + + printf "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\n" \ + "$tag" "${nops:-}" "${qubits:-}" "${tof:-}" "${score:-}" "${status:-}" "${ident:-}" "$wall" \ + "${config_root:-}" "${ops_hash:-}" "${trace_hash:-}" "${score_hash:-}" "${merkle:-}" \ + >> "$RESULTS_TSV" + echo " -> score=$score status=$status identity=$ident wall=${wall}s" + echo " merkle=${merkle:0:16}.. trace=${trace_hash:0:16}.. ops=${ops_hash:0:16}.. config=${config_root:0:16}.." + rm -f "$bin" "$ready" + touch "$QUEUE_DIR/${tag}.done" +done +' diff --git a/factory/bend-emit-pool.sh b/factory/bend-emit-pool.sh new file mode 100755 index 0000000..c212c4d --- /dev/null +++ b/factory/bend-emit-pool.sh @@ -0,0 +1,502 @@ +#!/usr/bin/env bash +# bend-emit-pool.sh — bounded parallel emit pool for circuit-emission cells. +# +# Reads work items from $LUMBDA_QUEUE_DIR/*.lsp. For each item : +# - skips if .ready or .done exists +# - skips if .emitting marker exists (in-flight) +# - throttles to MAX concurrent emits +# - launches $LUMBDA_EMITTER_CMD .lsp, expects it to write .bin +# - touches .ready when bin size > MIN_BIN_SIZE +# - touches .done if emit fails or bin stays too small +# +# Exits when no .lsp without a marker remains AND no .emitting markers active. +# Touch $LUMBDA_QUEUE_DIR/STOP to halt new launches gracefully. +# +# Liveness: +# - Writes $LUMBDA_QUEUE_DIR/pool.heartbeat (pid + timestamp) at top of every +# loop iter via lib-heartbeat.sh::heartbeat_touch. +# - On every exit path (STOP, drain timeout, signal trap, EXIT trap) +# writes $LUMBDA_QUEUE_DIR/pool.exit-cause with reason + removes heartbeat. +# - Supervisor reads pool.heartbeat to detect silent death. +# +# Usage: bend-emit-pool.sh [MAX [QUEUE_DIR [MIN_BIN_SIZE_BYTES]]] +# MAX default 6 +# QUEUE_DIR default $LUMBDA_QUEUE_DIR +# MIN_BIN_SIZE_BYTES default 268435456 (256 MB — sanity check only). +# +# Self-identifies as "bend-emit-pool" in cmdline for precise pkill targeting. +# +# Env vars consumed: see $LUMBDA_FACTORY_DIR/CONTRACT.md (LUMBDA_QUEUE_DIR, +# LUMBDA_DOMAIN_DIR, LUMBDA_REPO_DIR, LUMBDA_EMITTER_CMD, AUTO_PULL_MASTER, +# AUTO_PULL_TIMEOUT, DISK_MIN_FREE_GB, MEM_MIN_FREE_GB, POOL_MAX_IDLE_LOOPS, +# SLOW_MAX). +set -u + +MAX="${1:-6}" +QUEUE_DIR="${2:-${LUMBDA_QUEUE_DIR:-/tmp/lumbda-queue}}" +MIN_BIN_SIZE="${3:-268435456}" + +LUMBDA_DOMAIN_DIR="${LUMBDA_DOMAIN_DIR:-}" +LUMBDA_REPO_DIR="${LUMBDA_REPO_DIR:-$HOME/git/lumbda}" +LUMBDA_FACTORY_DIR="${LUMBDA_FACTORY_DIR:-$(dirname "$(readlink -f "$0")")}" +LUMBDA_EMITTER_CMD="${LUMBDA_EMITTER_CMD:?LUMBDA_EMITTER_CMD must be set by consumer (e.g. \"lumbda --fast \$LUMBDA_DOMAIN_DIR/lumbda/emit-stream.lsp\")}" +LIB_HEARTBEAT="${LIB_HEARTBEAT:-$LUMBDA_FACTORY_DIR/lib-heartbeat.sh}" +LIB_TIER="${LIB_TIER:-$LUMBDA_FACTORY_DIR/lib-tier.sh}" + +mkdir -p "$QUEUE_DIR" + +echo $$ > "$QUEUE_DIR/pool.pid" +trap 'rm -f "$QUEUE_DIR/pool.pid"' EXIT + +# Self-tag in cmdline so pkill -f bend-emit-pool only matches THIS script, +# not other bash sessions that happen to mention factory paths. +exec -a bend-emit-pool bash -c ' +QUEUE_DIR="'"$QUEUE_DIR"'" +MAX="'"$MAX"'" +MIN_BIN_SIZE="'"$MIN_BIN_SIZE"'" +LUMBDA_DOMAIN_DIR="'"$LUMBDA_DOMAIN_DIR"'" +LUMBDA_REPO_DIR="'"$LUMBDA_REPO_DIR"'" +LUMBDA_EMITTER_CMD="'"$LUMBDA_EMITTER_CMD"'" +LIB_HEARTBEAT="'"$LIB_HEARTBEAT"'" +LIB_TIER="'"$LIB_TIER"'" + +# Source liveness library — provides heartbeat_touch / heartbeat_is_alive / +# heartbeat_exit_cause. Path resolved by parent shell before exec so inner +# shell does not need to derive its own dirname. +# shellcheck source=/dev/null +. "$LIB_HEARTBEAT" +# Source bin-size tier classifier — provides tier_of_size / tier_label_dlq. +# Pool uses these to route oversize bins (above TIER_LARGE_MAX) to DLQ at +# finalize time instead of letting them flow downstream to crush the +# dispatcher fleet. +# shellcheck source=/dev/null +. "$LIB_TIER" + +echo "[$(date +%H:%M:%S)] bend-emit-pool start MAX=$MAX queue=$QUEUE_DIR" + +# Exit-cause writers. Every exit path (drain, STOP, signal) records its +# reason via the library before falling off the loop. EXIT trap acts as +# safety net for unforeseen crashes; the loop body sets a more specific +# reason just before break + EXIT trap then forwards it. +POOL_EXIT_REASON="" +on_exit() { + local r="${POOL_EXIT_REASON:-unknown-exit}" + heartbeat_exit_cause "$QUEUE_DIR" "pool" "$r" + echo "[$(date +%H:%M:%S)] bend-emit-pool exit reason=$r" +} +trap on_exit EXIT +trap "POOL_EXIT_REASON=signal-int; exit 130" INT +trap "POOL_EXIT_REASON=signal-term; exit 143" TERM + +# Pull origin/master before consuming a cell. Fail-soft: log a warning +# and return non-zero on failure (caller decides whether to keep emitting +# against checkout we have). Cheap (~1s fetch over LAN). Locked by +# .git/index.lock so concurrent pool restarts serialize cleanly. +pull_master_or_log() { + [ "${AUTO_PULL_MASTER:-1}" = "1" ] || return 0 + local out rc + out=$(timeout "${AUTO_PULL_TIMEOUT:-30}" git -C "$LUMBDA_REPO_DIR" pull --ff-only origin master 2>&1) + rc=$? + if [ "$rc" -ne 0 ]; then + echo "[$(date +%H:%M:%S)] PULL-FAIL rc=$rc (substrate may be stale): $(echo "$out" | tr "\n" "|" | cut -c-200)" + return "$rc" + fi + if ! echo "$out" | grep -q "Already up to date"; then + echo "[$(date +%H:%M:%S)] PULL ok: $(echo "$out" | tr "\n" "|" | cut -c-200)" + fi + return 0 +} + +# Self-healing janitor: clear .emitting markers whose emitter PID is dead. +# Called before every slot-count check. Stale markers can accrue when emits +# get SIGKILLed (OOM, manual cleanup) before they can clean up their own +# marker. +# +# Subshell wrapper around emitter touches .ready (or .done) BEFORE removing +# its own .emitting marker. A brief window exists where emitter has exited +# (PID dead) but parent subshell has not finished tail cleanup. If this +# janitor fires in that window, it must NOT treat emit as failed — +# .ready/.done file proves completion. Likewise if a .bin already exists +# at full size, emit was real and .ready marker may already have been +# consumed by dispatcher. +# +# NOTE: comments inside bash -c body must NOT contain apostrophes — each +# closes outer single-quoted argument early + corrupts parse. +heal_stale_markers() { + for em in "$QUEUE_DIR"/*.emitting; do + [ ! -f "$em" ] && continue + pid=$(cat "$em" 2>/dev/null) + if [ -z "$pid" ] || ! kill -0 "$pid" 2>/dev/null; then + tag=$(basename "$em" .emitting) + # If ANY completion artifact already exists, the emit completed + # before this janitor fired. Silently clear stale .emitting marker + # — no HEAL log, no .done touch, no relaunch. + if [ -f "$QUEUE_DIR/${tag}.ready" ] \ + || [ -f "$QUEUE_DIR/${tag}.done" ]; then + rm -f "$em" + continue + fi + # Orphan-bin recovery: if .bin exists at full size but no .ready/.done, + # subshell wrote .bin then died (SIGTERM mid-cleanup) before touching + # .ready. Promote: bin is real, dispatcher should consume it. Truncated + # bins (< MIN_BIN_SIZE) treated as failure — rm + .done so cell does + # not re-emit endlessly. + if [ -f "$QUEUE_DIR/${tag}.bin" ]; then + sz=$(stat -c %s "$QUEUE_DIR/${tag}.bin" 2>/dev/null || echo 0) + magic=$(head -c 8 "$QUEUE_DIR/${tag}.bin" 2>/dev/null) + if [ "$magic" != "QECCOPS1" ]; then + # Header-rewrite never fired. See finalize() comment for the + # SIGKILL/OOM mechanism. + mkdir -p "$QUEUE_DIR/dlq" + echo 1 > "$QUEUE_DIR/dlq/${tag}.retries" + { + echo "tier=zero-magic bin_bytes=$sz" + echo "reason: emit-interrupted (heal-stale path) — bin header magic missing" + echo "first-8-bytes-hex: $(head -c 8 $QUEUE_DIR/${tag}.bin 2>/dev/null | xxd -p -c 8)" + } > "$QUEUE_DIR/dlq/${tag}.reason" + echo "[$(date +%H:%M:%S)] DLQ orphan-bin-zero-magic $tag sz=$sz" + rm -f "$QUEUE_DIR/${tag}.bin" + touch "$QUEUE_DIR/${tag}.done.fail" + touch "$QUEUE_DIR/${tag}.done" + elif [ "$sz" -ge "$MIN_BIN_SIZE" ]; then + touch "$QUEUE_DIR/${tag}.ready" + echo "[$(date +%H:%M:%S)] RECOVER orphan-bin $tag ($(du -h $QUEUE_DIR/${tag}.bin | cut -f1))" + else + rm -f "$QUEUE_DIR/${tag}.bin" + touch "$QUEUE_DIR/${tag}.done" + echo "[$(date +%H:%M:%S)] HEAL orphan-bin-truncated $tag sz=$sz" + fi + rm -f "$em" + continue + fi + echo "[$(date +%H:%M:%S)] HEAL stale $tag (pid=$pid dead)" + rm -f "$em" + touch "$QUEUE_DIR/${tag}.done" + fi + done +} + +# Belt-and-suspenders: standalone scan for orphan .bin files whose .emitting +# marker is already gone (different death path than heal_stale_markers). +# Catches: +# - pool subshell died AFTER .emitting was racy-cleaned but +# BEFORE it touched .ready +# - pool process murdered between unrelated janitor pass + .ready touch +# - any .bin left behind by a manual operator intervention +# +# Same recovery rule as .emitting branch: full-size → .ready, truncated → +# rm + .done so cell does not re-emit forever. Skips bins already in flight +# (.inflight-N) or already complete (.ready / .done / .dispatch.log). +# Idempotent — safe to run every loop iter alongside heal_stale_markers. +heal_orphan_bins() { + shopt -s nullglob + for bin in "$QUEUE_DIR"/*.bin; do + tag=$(basename "$bin" .bin) + # Any in-progress or completion artifact = NOT orphan + [ -f "$QUEUE_DIR/${tag}.ready" ] && continue + [ -f "$QUEUE_DIR/${tag}.done" ] && continue + [ -f "$QUEUE_DIR/${tag}.emitting" ] && continue + [ -f "$QUEUE_DIR/${tag}.dispatch.log" ] && continue + if ls "$QUEUE_DIR/${tag}.inflight-"* >/dev/null 2>&1; then + continue + fi + sz=$(stat -c %s "$bin" 2>/dev/null || echo 0) + magic=$(head -c 8 "$bin" 2>/dev/null) + if [ "$magic" != "QECCOPS1" ]; then + # Same emit-interrupted class as finalize() + heal_stale_markers. + mkdir -p "$QUEUE_DIR/dlq" + echo 1 > "$QUEUE_DIR/dlq/${tag}.retries" + { + echo "tier=zero-magic bin_bytes=$sz" + echo "reason: emit-interrupted (orphan-bin-scan path) — bin header magic missing" + echo "first-8-bytes-hex: $(head -c 8 $bin 2>/dev/null | xxd -p -c 8)" + } > "$QUEUE_DIR/dlq/${tag}.reason" + echo "[$(date +%H:%M:%S)] DLQ orphan-bin-scan-zero-magic $tag sz=$sz" + rm -f "$bin" + touch "$QUEUE_DIR/${tag}.done.fail" + touch "$QUEUE_DIR/${tag}.done" + elif [ "$sz" -ge "$MIN_BIN_SIZE" ]; then + touch "$QUEUE_DIR/${tag}.ready" + echo "[$(date +%H:%M:%S)] RECOVER orphan-bin-scan $tag ($(du -h $bin | cut -f1))" + else + rm -f "$bin" + touch "$QUEUE_DIR/${tag}.done" + echo "[$(date +%H:%M:%S)] HEAL orphan-bin-scan-truncated $tag sz=$sz" + fi + done + shopt -u nullglob +} + +DISK_MIN_FREE_GB="${DISK_MIN_FREE_GB:-30}" +# Memory-free guard. Each emit RSS sits ~3-4 GiB at peak. With MAX=6 emits +# in flight + backend + dispatchers, total memory pressure can climb fast. +# Hold launches when free RAM falls below MEM_MIN_FREE_GB (default 8 GiB). +# Mirrors disk-free pattern: pool HOLDs rather than spawning an +# overcommit-OOM-kill cascade. +MEM_MIN_FREE_GB="${MEM_MIN_FREE_GB:-8}" +# Idle tolerance — pool stays alive while feeder may push more .lsp cells. +# Default 600 (x 5s = 50 min) — long enough to outlast feeder push cadence +# in normal operation. Exit only on STOP marker OR sustained idle past this +# bound. +POOL_MAX_IDLE_LOOPS="${POOL_MAX_IDLE_LOOPS:-600}" +# Substrate freshness — pull origin/master before emitting each cell so a +# backend never consumes a .lsp against stale substrate. Fail-soft: if pull +# fails (local mods, network), log + continue with checkout we have. Cell +# still emits — log entry tells operator "this host ran against potentially +# stale substrate". +AUTO_PULL_MASTER="${AUTO_PULL_MASTER:-1}" +AUTO_PULL_TIMEOUT="${AUTO_PULL_TIMEOUT:-30}" + +# Startup orphan sweep — runs BEFORE main loop so any leftover bins from a +# SIGKILL-d previous pool (whose subshell wrappers died before touching +# .ready) get promoted immediately. In-loop heal also runs, but only after +# a full poll cycle (~5s + admission checks), during which the new pool +# could start spawning fresh emits + pushing past orphans. Catching them +# at startup closes that window. +echo "[$(date +%H:%M:%S)] startup orphan scan" +heal_stale_markers +heal_orphan_bins + +idle_loops=0 +while true; do + # Heartbeat UNCONDITIONALLY at top of loop. Records both "I am alive" + # mtime + "my pid is X" content. Supervisor on this host reads it every + # poll cycle to decide whether to restart us. + heartbeat_touch "$QUEUE_DIR" "pool" + + if [ -f "$QUEUE_DIR/STOP" ]; then + echo "[$(date +%H:%M:%S)] STOP seen" + POOL_EXIT_REASON="stop-marker" + break + fi + pull_master_or_log || true + heal_stale_markers + heal_orphan_bins + # Disk-free guard. Emits land 4-6 GiB bins; running near zero free disk + # makes emitter spin on write retries instead of erroring out. Hold + # launches until at least DISK_MIN_FREE_GB available. + free_gb=$(df -BG --output=avail / 2>/dev/null | tail -1 | tr -dc 0-9) + if [ "${free_gb:-0}" -lt "$DISK_MIN_FREE_GB" ]; then + echo "[$(date +%H:%M:%S)] HOLD disk-free=${free_gb}G < ${DISK_MIN_FREE_GB}G, sleeping" + sleep 30 + continue + fi + # Memory-free guard. MAX=6 concurrent emits can each climb to ~3-4 GiB + # RSS; with backend + dispatchers also resident, sustained pressure + # approaches host limits. Hold new launches until MemAvailable >= + # MEM_MIN_FREE_GB so an OOM killer never picks a long-running emit + # at the worst moment. Same backoff sleep as disk guard. + free_mem_kb=$(grep ^MemAvailable: /proc/meminfo 2>/dev/null | tr -dc 0-9) + free_mem_gb=$(( ${free_mem_kb:-0} / 1048576 )) + if [ "$free_mem_gb" -lt "$MEM_MIN_FREE_GB" ]; then + echo "[$(date +%H:%M:%S)] HOLD mem-free=${free_mem_gb}G < ${MEM_MIN_FREE_GB}G, sleeping" + sleep 30 + continue + fi + # Read autoscaler advisory + apply dynamic MAX cap when RAM/swap pressure + # detected. If advisory says slow_emit=1, cap concurrency at SLOW_MAX + # (default = MAX/2). When pressure clears the advisory flips back to 0 + # and the cap restores. MEM_MIN_FREE_GB hold (above) is still the hard + # floor — advisory acts as a graceful intermediate signal. + effective_max="$MAX" + if [ -f "$QUEUE_DIR/emit.advisory" ]; then + slow=$(grep -E '^slow_emit=' "$QUEUE_DIR/emit.advisory" 2>/dev/null | tail -1 | cut -d= -f2) + if [ "${slow:-0}" = "1" ]; then + effective_max="${SLOW_MAX:-$(( MAX / 2 ))}" + [ "$effective_max" -lt 1 ] && effective_max=1 + fi + fi + # Find next pending work item + next="" + for f in "$QUEUE_DIR"/*.lsp; do + [ ! -f "$f" ] && continue + tag=$(basename "$f" .lsp) + [ -f "$QUEUE_DIR/${tag}.ready" ] && continue + [ -f "$QUEUE_DIR/${tag}.done" ] && continue + # .done.fail = operator/caller marked cell as skip (incompatible config, + # poison cell, retracted batch). Without this check pool re-emits the + # cell every iter even after the operator explicitly excluded it. + [ -f "$QUEUE_DIR/${tag}.done.fail" ] && continue + [ -f "$QUEUE_DIR/${tag}.emitting" ] && continue + # Dispatcher worker claims .ready by renaming to .inflight-N (atomic). + # If worker dies mid-dispatch (backend crash, kill, OOM) .inflight-N + # stays + no .done written. Treat .inflight-* as downstream-owned and + # do not re-emit. Dispatcher reclaim path runs at bend-dispatcher + # startup + heals stale .inflight-N back to .ready or .done. + # NOTE: comments here must NOT contain apostrophes — each closes outer + # single-quoted bash -c argument early + corrupts parse. + if ls "$QUEUE_DIR/${tag}.inflight-"* >/dev/null 2>&1; then + continue + fi + # Belt-and-suspenders against HEAL race: if a .bin exists at any size, + # an emit has run. Dispatcher consumes .bin + may delete .ready when + # done, leaving no other markers — without this check main loop would + # relaunch the cell after dispatcher consumed it. + [ -f "$QUEUE_DIR/${tag}.bin" ] && continue + next="$f" + break + done + if [ -z "$next" ]; then + # No new items — wait for in-flight or for feeder to push more. + running=$(ls "$QUEUE_DIR"/*.emitting 2>/dev/null | wc -l) + if [ "$running" = "0" ]; then + idle_loops=$((idle_loops + 1)) + if [ "$idle_loops" -ge "$POOL_MAX_IDLE_LOOPS" ]; then + echo "[$(date +%H:%M:%S)] pool drained + idle past $POOL_MAX_IDLE_LOOPS loops" + POOL_EXIT_REASON="drain-timeout" + break + fi + fi + sleep 5 + continue + fi + idle_loops=0 + # Throttle to MAX concurrent (self-healing each check). Heartbeat again + # inside throttle wait — long emits can hold us here for minutes; without + # re-touching heartbeat supervisor would see us as dead. + while true; do + heartbeat_touch "$QUEUE_DIR" "pool" + heal_stale_markers + heal_orphan_bins + running=$(ls "$QUEUE_DIR"/*.emitting 2>/dev/null | wc -l) + # Compare against effective_max (advisory-aware) rather than raw MAX + # so RAM-pressure slow-down actually reduces concurrency. effective_max + # computed once per main-loop iter against latest advisory. + [ "$running" -lt "$effective_max" ] && break + sleep 3 + done + tag=$(basename "$next" .lsp) + echo "[$(date +%H:%M:%S)] launch $tag" + # Subshell: traps EXIT/HUP/TERM so partial emit still finalizes (.ready + # or .done) when parent pool dies during hot-reload. SIGHUP explicitly + # ignored — propagated from a dying parent must NOT kill the wrapper + # mid-cleanup. SIGKILL on us still leaks (no trap fires), but startup + # heal_orphan_bins promotes those bins on next pool start. + ( + trap "" HUP + bin="$QUEUE_DIR/${tag}.bin" + finalize() { + if [ -f "$bin" ]; then + sz=$(stat -c %s "$bin" 2>/dev/null || echo 0) + # Bin-magic check FIRST. Interrupted emits (OOM-killed mid-write, + # SIGKILL on emitter hang) leave the 16-byte header reserve as + # zero bytes — emit-stream writes 16 zeros, streams ops, then + # seeks back to byte 0 to rewrite QECCOPS1 + n_ops at the end. + # SIGKILL between those steps strands a file with zero magic. + # Downstream backend chokes with opaque "bad magic" → bin-load-fail + # → DLQ with no useful forensic info. Route here with actual cause + # named so operators can trace back to upstream cell hang instead + # of guessing at load_ops_bin internals. + magic=$(head -c 8 "$bin" 2>/dev/null) + if [ "$magic" != "QECCOPS1" ]; then + mkdir -p "$QUEUE_DIR/dlq" + echo 1 > "$QUEUE_DIR/dlq/${tag}.retries" + { + echo "tier=zero-magic bin_bytes=$sz" + echo "reason: emit-interrupted — bin header magic missing or non-QECCOPS1 (likely SIGKILL or OOM mid-emit; emit-stream header rewrite never fired)" + echo "first-8-bytes-hex: $(head -c 8 "$bin" 2>/dev/null | xxd -p -c 8)" + echo "--- last 10 lines of emit.log ---" + tail -10 "$QUEUE_DIR/${tag}.emit.log" 2>/dev/null + } > "$QUEUE_DIR/dlq/${tag}.reason" + echo "[$(date +%H:%M:%S)] DLQ $tag zero-magic sz=$sz ($(printf %.0f $((sz/1024/1024)))MiB) — emit-interrupted" + rm -f "$bin" + touch "$QUEUE_DIR/${tag}.done.fail" + touch "$QUEUE_DIR/${tag}.done" + rm -f "$QUEUE_DIR/${tag}.emitting" + return 0 + fi + # 2nd sub-class: GOOD magic + n_ops=0 — emit wrote QECCOPS1 magic + + # streamed ops but SIGKILL hit between stream-end + finalize seek- + # back-to-byte-8 that rewrites n_ops. Detect via n_ops=0 + # implausibility check: any in-tier bin should have n_ops > 0; + # if not, finalize never fired. + n_ops_le=$(dd if="$bin" bs=1 count=8 skip=8 2>/dev/null | xxd -p -c 8) + if [ "$n_ops_le" = "0000000000000000" ]; then + mkdir -p "$QUEUE_DIR/dlq" + echo 1 > "$QUEUE_DIR/dlq/${tag}.retries" + { + echo "tier=zero-n_ops bin_bytes=$sz" + echo "reason: emit-finalize-never-fired — QECCOPS1 magic present but n_ops field at byte 8 is zero (SIGKILL between stream-end + emit-stream seek-back; downstream load_ops_bin would fail length-mismatch)" + echo "n_ops_le_hex: $n_ops_le" + echo "--- last 10 lines of emit.log ---" + tail -10 "$QUEUE_DIR/${tag}.emit.log" 2>/dev/null + } > "$QUEUE_DIR/dlq/${tag}.reason" + echo "[$(date +%H:%M:%S)] DLQ $tag zero-n_ops sz=$sz ($(printf %.0f $((sz/1024/1024)))MiB) — emit-finalize-never-fired" + rm -f "$bin" + touch "$QUEUE_DIR/${tag}.done.fail" + touch "$QUEUE_DIR/${tag}.done" + rm -f "$QUEUE_DIR/${tag}.emitting" + return 0 + fi + # Tier-classify the bin. Tier "below-min" / "above-max" → DLQ with + # a typed reason. In-band tiers (micro/small/medium/large) get + # promoted to .ready + dispatcher routes through tier-specific + # admission. lib-tier.sh owns boundary policy. + tier=$(tier_of_size "$sz") + dlq_reason=$(tier_label_dlq "$tier") + if [ -n "$dlq_reason" ]; then + mkdir -p "$QUEUE_DIR/dlq" + echo 1 > "$QUEUE_DIR/dlq/${tag}.retries" + { + echo "tier=$tier bin_bytes=$sz" + echo "reason: $dlq_reason" + echo "--- last 10 lines of emit.log ---" + tail -10 "$QUEUE_DIR/${tag}.emit.log" 2>/dev/null + } > "$QUEUE_DIR/dlq/${tag}.reason" + echo "[$(date +%H:%M:%S)] DLQ $tag tier=$tier sz=$sz ($(printf %.0f $((sz/1024/1024)))MiB) — $dlq_reason" + rm -f "$bin" + touch "$QUEUE_DIR/${tag}.done.fail" + touch "$QUEUE_DIR/${tag}.done" + else + # In-tier bin → optional domain-specific sidecar (vorticity, etc), + # then mark .ready. Sidecar lands next to .bin. Read-only + # post-process; emit substrate untouched. Fail-soft: sidecar + # script errors log + continue — bin still promotes to .ready. + # Dispatcher reads .bin, ignores sidecar; operators + analysis + # tooling consume sidecar opportunistically. + vort="$QUEUE_DIR/${tag}.vorticity.tsv" + if [ -n "$LUMBDA_DOMAIN_DIR" ] && [ -x "$LUMBDA_DOMAIN_DIR/scripts/qubit-vorticity.py" ]; then + if "$LUMBDA_DOMAIN_DIR/scripts/qubit-vorticity.py" "$bin" --out "$vort" \ + > "$QUEUE_DIR/${tag}.vorticity.log" 2>&1; then + : + else + echo "[$(date +%H:%M:%S)] vorticity $tag FAILED (see ${tag}.vorticity.log) — promoting bin anyway" + fi + fi + touch "$QUEUE_DIR/${tag}.ready" + echo "[$(date +%H:%M:%S)] ready $tag tier=$tier ($(du -h $bin | cut -f1))" + fi + else + # No bin — emitter errored before writing (undefined flag, syntax + # error, load failure, etc). Emit failures stay DETERMINISTIC — + # retry will fail the same way. Route to DLQ for forensics, mark + # .done.fail + .done so pool skips on next iter (no infinite + # relaunch loop). + mkdir -p "$QUEUE_DIR/dlq" + echo 1 > "$QUEUE_DIR/dlq/${tag}.retries" + tail -10 "$QUEUE_DIR/${tag}.emit.log" 2>/dev/null > "$QUEUE_DIR/dlq/${tag}.reason" + echo "[$(date +%H:%M:%S)] DLQ $tag (emit error — see dlq/${tag}.reason)" + touch "$QUEUE_DIR/${tag}.done.fail" + touch "$QUEUE_DIR/${tag}.done" + fi + rm -f "$QUEUE_DIR/${tag}.emitting" + } + trap finalize EXIT + trap "kill \$lpid 2>/dev/null; finalize; exit 130" INT + trap "kill \$lpid 2>/dev/null; finalize; exit 143" TERM + if [ -n "$LUMBDA_DOMAIN_DIR" ]; then + cd "$LUMBDA_DOMAIN_DIR" + fi + PYTHONUNBUFFERED=1 ECDSA_OUT_BIN="$QUEUE_DIR/${tag}.bin" \ + $LUMBDA_EMITTER_CMD "$next" \ + > "$QUEUE_DIR/${tag}.emit.log" 2>&1 & + lpid=$! + echo "$lpid" > "$QUEUE_DIR/${tag}.emitting" + wait "$lpid" + ) & +done +wait +echo "[$(date +%H:%M:%S)] all emits done" +# Loop exited cleanly via STOP / drain; POOL_EXIT_REASON already set. +# EXIT trap calls heartbeat_exit_cause. +' diff --git a/factory/bend-supervisor-dlq-runner.sh b/factory/bend-supervisor-dlq-runner.sh new file mode 100755 index 0000000..aebae5a --- /dev/null +++ b/factory/bend-supervisor-dlq-runner.sh @@ -0,0 +1,278 @@ +#!/usr/bin/env bash +# bend-supervisor-dlq-runner.sh — auto-resolve loop for our DLQ. +# +# Polls $LUMBDA_QUEUE_DIR/dlq every $DLQ_POLL_S seconds. For each retry- +# eligible entry (has a .bin in dlq/), classify by reason file, decide: +# +# AUTO-RETRY → move .bin back to queue + touch .ready. Counters in +# $LUMBDA_QUEUE_DIR/dlq/.retries persist across passes. +# When retries reach AUTO_RETRY_MAX for an auto class, +# we ESCALATE instead. +# +# ESCALATE → move bin + reason + retries + copy .lsp into +# $LUMBDA_QUEUE_DIR/rdlq/. Cell now waits for operator +# to run a retry workflow. +# +# DROP → for cells whose .bin stays missing or 0-byte (emit truly +# failed; nothing to preserve). Touch .done.fail. +# +# State-stage classification drives WHAT we preserve when escalating: +# stage=emit → .lsp matters, .bin disposable (pool re-emits) +# stage=dispatch → .bin good, dispatcher infrastructure broke; retry +# preserves .bin +# stage=sim → .bin good, but backend failed (OOM / illegal-addr +# / etc). Operator decides: retry with different +# n_batches, or patch backend + rebuild, or quarantine. +# +# Designed to run as one supervisor-managed worker. Heartbeats to +# $LUMBDA_QUEUE_DIR/dlq-runner.heartbeat; supervisor restarts if stale. +# +# Exit signals: +# - $LUMBDA_QUEUE_DIR/DLQ_RUNNER_STOP marker +# - SIGTERM / SIGINT +# +# Env vars consumed: see $LUMBDA_FACTORY_DIR/CONTRACT.md (LUMBDA_QUEUE_DIR, +# DLQ_POLL_S, AUTO_RETRY_MAX, DLQ_RUNNER_LOG). +set -u + +QUEUE_DIR="${LUMBDA_QUEUE_DIR:-${QUEUE_DIR:-/tmp/lumbda-queue}}" +DLQ_POLL_S="${DLQ_POLL_S:-30}" +AUTO_RETRY_MAX="${AUTO_RETRY_MAX:-3}" +LOG="${DLQ_RUNNER_LOG:-$QUEUE_DIR/dlq-runner.log}" +STOP_FILE="$QUEUE_DIR/DLQ_RUNNER_STOP" +RDLQ_DIR="$QUEUE_DIR/rdlq" + +LUMBDA_FACTORY_DIR="${LUMBDA_FACTORY_DIR:-$(dirname "$(readlink -f "$0")")}" +LIB_HEARTBEAT="${LIB_HEARTBEAT:-$LUMBDA_FACTORY_DIR/lib-heartbeat.sh}" +# shellcheck source=/dev/null +. "$LIB_HEARTBEAT" + +mkdir -p "$RDLQ_DIR" + +log() { + local ts msg + ts=$(date +%H:%M:%S) + msg="[$ts] $*" + echo "$msg" | tee -a "$LOG" +} + +# Classification table — single source of truth. Returns one of: +# auto-retry missing-bin bisect-pool-race cuda-error-transient no-portal +# escalate cuda-oom cuda-illegal-addr bin-load-fail +# memory-cap-refused tier-classify unknown +# +# classify_reason +# echoes " " +# class — one of named classes above +# stage — emit | dispatch | sim +# salvage_bin — yes | no (yes = preserve .bin on escalate; no = re-emit needed) +classify_reason() { + local r="$1" + if [ ! -f "$r" ]; then + echo "unknown unknown no"; return + fi + # Empty or whitespace-only .reason files: classify as transient-empty-reason + # directly. Auto-retry class. After AUTO_RETRY_MAX (3) escalates, but noise + # stays contained AND operators see the right label. + if [ ! -s "$r" ] || ! grep -qE '[^[:space:]]' "$r" 2>/dev/null; then + echo "transient-empty-reason sim yes"; return + fi + # Specific (code XXX) matches FIRST — typed portals carry most reliable + # signal. Generic "cuda-sim-error" / "cuda-error" catch-all comes last + # so bin-load-fail / memory-cap-refused etc. don't get silently swallowed. + if grep -q "cuda-oom\|cudaMalloc.*out of memory\|cudaErrorMemoryAllocation" "$r" 2>/dev/null; then + echo "cuda-oom sim yes"; return + fi + if grep -q "cuda-illegal-addr\|cudaErrorIllegalAddress" "$r" 2>/dev/null; then + echo "cuda-illegal-addr sim yes"; return + fi + if grep -q "memory-cap-refused" "$r" 2>/dev/null; then + echo "memory-cap-refused sim yes"; return + fi + # Fast-fail (backend pre-flight cudaMemGetInfo). Bin is fine; needs + # n_batches reduction or wait for less GPU contention. + if grep -q "vram-budget-refused" "$r" 2>/dev/null; then + echo "vram-budget-refused sim yes"; return + fi + if grep -q "bin-load-fail" "$r" 2>/dev/null; then + echo "bin-load-fail emit no"; return + fi + # Emit-stage (pool DLQ'd at finalize) + if grep -q "tier=zero-magic\|tier=zero-n_ops\|emit-interrupted" "$r" 2>/dev/null; then + echo "emit-broken emit no"; return + fi + if grep -q "tier=above-max\|tier=below-min" "$r" 2>/dev/null; then + echo "tier-classify emit no"; return + fi + # Generic typed cuda error catchall — fired when CUDA_CHECK surfaced an + # error not matched by oom/illegal-addr/memory-cap. + if grep -q "cuda-sim-error\|cuda-error" "$r" 2>/dev/null; then + echo "cuda-error-transient sim yes"; return + fi + # Dispatch-stage (backend infrastructure) + if grep -q "^missing:" "$r" 2>/dev/null; then + echo "missing-bin dispatch yes"; return + fi + # BISECT-DIAG entries are NOT a step6 crash — they are pool finalize() + # race vs heal_orphan_bins where .bin got consumed/deleted between + # subshell-exit and finalize check. Cells actually completed emit. So + # retry-emit is safe; the bin is gone. + if grep -q "BISECT-DIAG" "$r" 2>/dev/null; then + echo "bisect-pool-race emit no"; return + fi + # Generic no-portal — backend crashed without writing typed portal. + if grep -q "no-portal" "$r" 2>/dev/null; then + echo "no-portal sim yes"; return + fi + echo "unknown unknown no" +} + +# Auto-retry classes — these resolve themselves with a re-try. +is_auto_class() { + case "$1" in + missing-bin|bisect-pool-race|cuda-error-transient|no-portal|transient-empty-reason) return 0 ;; + *) return 1 ;; + esac +} + +# Escalate-on-first-fail classes — no point in auto-retrying. +is_escalate_class() { + case "$1" in + cuda-oom|cuda-illegal-addr|memory-cap-refused|vram-budget-refused|bin-load-fail|tier-classify|emit-broken|unknown) return 0 ;; + *) return 1 ;; + esac +} + +# Move from dlq/ back to queue/ for another dispatcher attempt. +auto_retry_one() { + local tag="$1" reason_class="$2" + local bin="$QUEUE_DIR/dlq/${tag}.bin" + local ready="$QUEUE_DIR/${tag}.ready" + if [ ! -f "$bin" ]; then + # Bin missing in DLQ — nothing to retry. Drop to .done.fail so pool + # stops re-emitting. + touch "$QUEUE_DIR/${tag}.done.fail" + touch "$QUEUE_DIR/${tag}.done" + rm -f "$QUEUE_DIR/dlq/${tag}.reason" "$QUEUE_DIR/dlq/${tag}.retries" + log "DROP $tag class=$reason_class (no .bin in dlq, marking done.fail)" + return + fi + mv "$bin" "$QUEUE_DIR/${tag}.bin" + touch "$ready" + log "AUTO-RETRY $tag class=$reason_class -> .ready" +} + +# Escalate from dlq/ to rdlq/. Preserves .bin if salvage_bin=yes, +# always copies .lsp source for operator to inspect or re-emit from. +escalate_one() { + local tag="$1" reason_class="$2" stage="$3" salvage="$4" + local dlq_bin="$QUEUE_DIR/dlq/${tag}.bin" + local dlq_reason="$QUEUE_DIR/dlq/${tag}.reason" + local dlq_retries="$QUEUE_DIR/dlq/${tag}.retries" + local rdlq_bin="$RDLQ_DIR/${tag}.bin" + local rdlq_reason="$RDLQ_DIR/${tag}.reason" + local rdlq_retries="$RDLQ_DIR/${tag}.retries" + local rdlq_stage="$RDLQ_DIR/${tag}.stage" + local rdlq_class="$RDLQ_DIR/${tag}.class" + local rdlq_lsp="$RDLQ_DIR/${tag}.lsp" + local rdlq_first="$RDLQ_DIR/${tag}.first-seen" + local src_lsp="$QUEUE_DIR/${tag}.lsp" + local retries=0 + [ -f "$dlq_retries" ] && retries=$(cat "$dlq_retries" 2>/dev/null) + [ -z "$retries" ] && retries=0 + + if [ "$salvage" = "yes" ] && [ -f "$dlq_bin" ]; then + mv "$dlq_bin" "$rdlq_bin" + elif [ -f "$dlq_bin" ]; then + # salvage=no — bin is suspect; remove so retry-reemit is the only path + rm -f "$dlq_bin" + fi + # Copy .lsp if it still exists in queue. (Pool may have already + # rm'd it once the cell hit .done.) If missing, escalation goes + # forward without source — operator pulls from git. + if [ -f "$src_lsp" ]; then + cp "$src_lsp" "$rdlq_lsp" + fi + { + echo "# rDLQ entry — escalated $(date -u +%FT%TZ)" + echo "# class: $reason_class" + echo "# stage: $stage" + echo "# salvage_bin: $salvage" + echo "# retries-at-escalation: $retries" + echo "" + echo "## Original DLQ reason:" + if [ -f "$dlq_reason" ]; then cat "$dlq_reason"; fi + } > "$rdlq_reason" + echo "$retries" > "$rdlq_retries" + echo "$stage" > "$rdlq_stage" + echo "$reason_class" > "$rdlq_class" + [ ! -f "$rdlq_first" ] && date -u +%FT%TZ > "$rdlq_first" + rm -f "$dlq_bin" "$dlq_reason" "$dlq_retries" + # Mark .done.fail so pool stops re-emitting while cell sits in rDLQ. + # Re-emit path clears these. + touch "$QUEUE_DIR/${tag}.done.fail" + touch "$QUEUE_DIR/${tag}.done" + log "ESCALATE $tag class=$reason_class stage=$stage salvage=$salvage retries=$retries -> rdlq/" +} + +# One pass over the DLQ. Increments cell-local retry only on auto-retry +# decisions (so escalate paths don't inflate counter unfairly). +process_one_pass() { + shopt -s nullglob + local f tag class stage salvage parts + for f in "$QUEUE_DIR"/dlq/*.reason; do + [ -f "$f" ] || continue + tag=$(basename "$f" .reason) + parts=$(classify_reason "$f") + class=$(echo "$parts" | awk '{print $1}') + stage=$(echo "$parts" | awk '{print $2}') + salvage=$(echo "$parts" | awk '{print $3}') + + local retries=0 + [ -f "$QUEUE_DIR/dlq/${tag}.retries" ] && retries=$(cat "$QUEUE_DIR/dlq/${tag}.retries" 2>/dev/null) + [ -z "$retries" ] && retries=0 + + if is_escalate_class "$class"; then + escalate_one "$tag" "$class" "$stage" "$salvage" + continue + fi + if is_auto_class "$class"; then + if [ "$retries" -ge "$AUTO_RETRY_MAX" ]; then + # Auto class exhausted retries — escalate. + escalate_one "$tag" "$class" "$stage" "$salvage" + continue + fi + retries=$((retries + 1)) + echo "$retries" > "$QUEUE_DIR/dlq/${tag}.retries" + auto_retry_one "$tag" "$class" + continue + fi + # Unknown classifier — escalate defensively (operator decides). + escalate_one "$tag" "$class" "$stage" "$salvage" + done + shopt -u nullglob +} + +EXIT_REASON="" +on_exit() { + local r="${EXIT_REASON:-unknown-exit}" + heartbeat_exit_cause "$QUEUE_DIR" "dlq-runner" "$r" + echo "[$(date +%H:%M:%S)] bend-supervisor-dlq-runner exit reason=$r" | tee -a "$LOG" +} +trap on_exit EXIT +trap 'EXIT_REASON=signal-int; exit 130' INT +trap 'EXIT_REASON=signal-term; exit 143' TERM + +log "bend-supervisor-dlq-runner start queue=$QUEUE_DIR poll=${DLQ_POLL_S}s auto_max=$AUTO_RETRY_MAX" + +while true; do + heartbeat_touch "$QUEUE_DIR" "dlq-runner" + if [ -f "$STOP_FILE" ]; then + log "STOP marker — exiting" + rm -f "$STOP_FILE" + EXIT_REASON="stop-marker" + break + fi + process_one_pass + sleep "$DLQ_POLL_S" +done diff --git a/factory/bend-supervisor.sh b/factory/bend-supervisor.sh new file mode 100755 index 0000000..1d62862 --- /dev/null +++ b/factory/bend-supervisor.sh @@ -0,0 +1,353 @@ +#!/usr/bin/env bash +# bend-supervisor.sh — per-host local watchdog for a bend factory. +# +# Runs ON each backend host. Owns local liveness for that host's components: +# 1. backend (gpu-worker) on $BEND_PORT_LISTEN +# 2. bend-emit-pool.sh (consumes .lsp from $LUMBDA_QUEUE_DIR) +# 3. bend-dispatcher.sh (consumes .ready, writes results.tsv) +# 4. bend-supervisor-dlq-runner.sh (DLQ classifier + auto-retry) +# 5. bend-autoscaler.sh (V2 live-VRAM controller; optional) +# +# Reads heartbeats produced by lib-heartbeat.sh: +# $LUMBDA_QUEUE_DIR/pool.heartbeat (pool) +# $LUMBDA_QUEUE_DIR/dispatcher-.heartbeat (dispatcher per worker) +# backend liveness: TCP LISTEN socket on $BEND_PORT_LISTEN (not an hb) +# +# Restart policy: +# - backend: restart when port not listening +# - pool: restart when heartbeat stale AND any .lsp lacks marker +# - dispatcher: restart when ALL workers' heartbeats stale AND .ready +# or .bin exists (work waiting). +# +# Persistent loop. Exit only on: +# - $LUMBDA_QUEUE_DIR/SUPERVISOR_STOP marker +# - SIGINT / SIGTERM +# No auto-exit on idle. +# +# Env vars consumed: see $LUMBDA_FACTORY_DIR/CONTRACT.md (LUMBDA_QUEUE_DIR, +# LUMBDA_FACTORY_DIR, LUMBDA_DOMAIN_DIR, LUMBDA_REPO_DIR, LUMBDA_BACKEND_CMD, +# LUMBDA_EMITTER_CMD, BEND_PORT_LISTEN, BEND_ENDPOINTS, POOL_MAX, +# POOL_MIN_BIN, POOL_BATCHES, POLL_SECONDS, POOL_STALE_SEC, DISP_STALE_SEC, +# SUPERVISOR_LOG). +# +# Usage: +# LUMBDA_QUEUE_DIR=/tmp/lumbda-queue BEND_PORT_LISTEN=8320 \ +# bend-supervisor.sh +set -u + +QUEUE_DIR="${LUMBDA_QUEUE_DIR:-${QUEUE_DIR:-/tmp/lumbda-queue}}" +LUMBDA_DOMAIN_DIR="${LUMBDA_DOMAIN_DIR:-}" +LUMBDA_REPO_DIR="${LUMBDA_REPO_DIR:-$HOME/git/lumbda}" +LUMBDA_FACTORY_DIR="${LUMBDA_FACTORY_DIR:-$(dirname "$(readlink -f "$0")")}" +# Backend launch knobs — set by consumer. +LUMBDA_BACKEND_CMD="${LUMBDA_BACKEND_CMD:-bend-cuda}" +# Optional cuda-fanout dir for lumbda-worker bootstrap script. +CUDA_FANOUT_DIR="${CUDA_FANOUT_DIR:-$LUMBDA_REPO_DIR/examples/cuda-fanout}" +# Lumbda C binary — needed only for the gpu-worker.lsp bootstrap path. +# Consumer can override; if missing we skip the worker launch helper and +# the operator handles backend lifecycle out-of-band. +LUMBDA_C_BIN="${LUMBDA_C_BIN:-$LUMBDA_REPO_DIR/c/lumbda}" +BEND_PORT_LISTEN="${BEND_PORT_LISTEN:-8320}" +BEND_ENDPOINTS="${BEND_ENDPOINTS:-127.0.0.1:${BEND_PORT_LISTEN}}" +POOL_MAX="${POOL_MAX:-12}" +POOL_MIN_BIN="${POOL_MIN_BIN:-268435456}" +POOL_BATCHES="${POOL_BATCHES:-141}" +POLL_SECONDS="${POLL_SECONDS:-30}" +POOL_STALE_SEC="${POOL_STALE_SEC:-180}" +DISP_STALE_SEC="${DISP_STALE_SEC:-300}" +SUPERVISOR_LOG="${SUPERVISOR_LOG:-$QUEUE_DIR/supervisor.log}" +LIB_HEARTBEAT="${LIB_HEARTBEAT:-$LUMBDA_FACTORY_DIR/lib-heartbeat.sh}" +LIB_TIER="${LIB_TIER:-$LUMBDA_FACTORY_DIR/lib-tier.sh}" + +# shellcheck source=/dev/null +. "$LIB_HEARTBEAT" +# Source tier policy so reload_config's tier_fingerprint sees defaults at +# first boot. supervisor.config overrides flow through `set -a; . "$CONFIG_FILE"; +# set +a` below + propagate to child env. +# shellcheck source=/dev/null +. "$LIB_TIER" + +mkdir -p "$QUEUE_DIR" + +PID_FILE="$QUEUE_DIR/supervisor.pid" +STOP_FILE="$QUEUE_DIR/SUPERVISOR_STOP" + +# Singleton via PID file. If a prior supervisor's pid stays alive, refuse +# to start. If pidfile stays stale (pid dead), claim it. +if [ -f "$PID_FILE" ]; then + old_pid=$(cat "$PID_FILE" 2>/dev/null) + if [ -n "$old_pid" ] && kill -0 "$old_pid" 2>/dev/null; then + echo "[$(date +%H:%M:%S)] bend-supervisor: another instance alive (pid=$old_pid); refusing to start" >&2 + exit 1 + fi +fi +echo $$ > "$PID_FILE" + +SUP_EXIT_REASON="" +on_exit() { + local r="${SUP_EXIT_REASON:-unknown-exit}" + heartbeat_exit_cause "$QUEUE_DIR" "supervisor" "$r" + rm -f "$PID_FILE" + echo "[$(date +%H:%M:%S)] bend-supervisor exit reason=$r" >> "$SUPERVISOR_LOG" +} +trap on_exit EXIT +trap 'SUP_EXIT_REASON=signal-int; exit 130' INT +trap 'SUP_EXIT_REASON=signal-term; exit 143' TERM + +log() { + local ts msg + ts=$(date +%H:%M:%S) + msg="[$ts] $*" + echo "$msg" | tee -a "$SUPERVISOR_LOG" +} + +log "bend-supervisor start queue=$QUEUE_DIR port=$BEND_PORT_LISTEN" +log " pool-stale=${POOL_STALE_SEC}s disp-stale=${DISP_STALE_SEC}s poll=${POLL_SECONDS}s" + +# ── component-1: backend (gpu-worker) ─────────────────────────────── +# Listening on TCP $BEND_PORT_LISTEN means alive. No heartbeat file — +# backend = lumbda + cuda, not a script we own. +bend_port_listening() { + ss -tnlp 2>/dev/null | grep -q "0.0.0.0:${BEND_PORT_LISTEN} " +} + +restart_bend() { + log "restart backend gpu-worker on :${BEND_PORT_LISTEN}" + local launch_lsp="/tmp/launch-worker-${BEND_PORT_LISTEN}.lsp" + local bend_log="/tmp/bend-worker-${BEND_PORT_LISTEN}.log" + if [ ! -x "$LUMBDA_C_BIN" ] || [ ! -d "$CUDA_FANOUT_DIR" ]; then + log "skip backend restart — LUMBDA_C_BIN ($LUMBDA_C_BIN) or CUDA_FANOUT_DIR ($CUDA_FANOUT_DIR) missing; consumer owns backend lifecycle" + return 1 + fi + printf '%s\n' \ + "(define *argv* (quote (\"--port\" \"${BEND_PORT_LISTEN}\")))" \ + "(load \"wire.lsp\")" \ + "(load \"gpu-worker.lsp\")" \ + "(main)" \ + > "$launch_lsp" + ( + cd "$CUDA_FANOUT_DIR" || exit 1 + PYTHONUNBUFFERED=1 nohup "$LUMBDA_C_BIN" "$launch_lsp" \ + >> "$bend_log" 2>&1 & + ) + sleep 5 + if bend_port_listening; then + log "backend back up on :${BEND_PORT_LISTEN}" + return 0 + fi + log "backend FAILED to come back up — will retry next poll" + return 1 +} + +# ── component-2: bend-emit-pool ───────────────────────────────────── +# Heartbeat at $QUEUE_DIR/pool.heartbeat. Stale check delegated to lib. +# Restart predicate: stale AND there's actually un-emitted work. +pool_alive() { + heartbeat_is_alive "$QUEUE_DIR" "pool" "$POOL_STALE_SEC" +} + +count_unworked_lsp() { + local n=0 + for f in "$QUEUE_DIR"/*.lsp; do + [ -f "$f" ] || continue + local tag + tag=$(basename "$f" .lsp) + [ -f "$QUEUE_DIR/${tag}.ready" ] && continue + [ -f "$QUEUE_DIR/${tag}.done" ] && continue + [ -f "$QUEUE_DIR/${tag}.emitting" ] && continue + n=$((n + 1)) + done + echo "$n" +} + +restart_pool() { + # Factory-protection: bash -n the pool script BEFORE spawning. A + # one-character apostrophe in a comment can close the outer + # exec -a NAME bash -c quote and crash-loop a pool every 30s. + # bash -n catches that statically. If a script breaks, refuse to + # spawn + log loudly. Last-known-good in-memory pool keeps running + # until a human fixes master. + local pool_script="$LUMBDA_FACTORY_DIR/bend-emit-pool.sh" + if ! bash -n "$pool_script" 2>/tmp/pool-syntax.err; then + log "REFUSING to spawn pool — bend-emit-pool.sh failed bash -n:" + sed 's/^/ /' /tmp/pool-syntax.err | while read line; do log "$line"; done + log "fix master + push; supervisor will retry on next loop" + rm -f /tmp/pool-syntax.err + return 1 + fi + rm -f /tmp/pool-syntax.err + log "restart bend-emit-pool" + # Clean stale .emitting + STOP markers before relaunch — the old pool + # may have left these around. + rm -f "$QUEUE_DIR"/*.emitting "$QUEUE_DIR/STOP" 2>/dev/null + LUMBDA_DOMAIN_DIR="$LUMBDA_DOMAIN_DIR" \ + LUMBDA_REPO_DIR="$LUMBDA_REPO_DIR" \ + LUMBDA_FACTORY_DIR="$LUMBDA_FACTORY_DIR" \ + LUMBDA_EMITTER_CMD="${LUMBDA_EMITTER_CMD:-}" \ + setsid nohup "$pool_script" \ + "$POOL_MAX" "$QUEUE_DIR" "$POOL_MIN_BIN" \ + >> "$QUEUE_DIR/pool.log" 2>&1 < /dev/null & +} + +# ── component-3: bend-dispatcher ──────────────────────────────────── +# Multi-worker dispatcher writes per-worker heartbeats. Considered alive +# if ANY worker's heartbeat stays fresh — single-worker stalls absorbed +# by others. Considered dead only if NO worker heartbeat stays fresh +# AND .ready or .bin work waits. +# +# Discovery: glob $QUEUE_DIR/dispatcher-*.heartbeat. Empty glob → no +# dispatcher ever ran → restart if work waits. +dispatcher_any_alive() { + local hb + for hb in "$QUEUE_DIR"/dispatcher-*.heartbeat; do + [ -f "$hb" ] || continue + local svc + svc=$(basename "$hb" .heartbeat) + if heartbeat_is_alive "$QUEUE_DIR" "$svc" "$DISP_STALE_SEC"; then + return 0 + fi + done + # Fall through: singleton dispatcher (this script) writes + # dispatcher.heartbeat directly when present. + heartbeat_is_alive "$QUEUE_DIR" "dispatcher" "$DISP_STALE_SEC" +} + +count_dispatchable() { + local n + n=$(ls "$QUEUE_DIR"/*.ready "$QUEUE_DIR"/*.bin 2>/dev/null | wc -l) + echo "$n" +} + +restart_dispatcher() { + log "restart bend-dispatcher BEND_ENDPOINTS=$BEND_ENDPOINTS" + # Stale heartbeats / inflight markers will be reclaimed by a new + # dispatcher's startup orphan-reclaim block. Clean only the lock so + # new instance can flock. + rm -f "$QUEUE_DIR/dispatcher.lock" "$QUEUE_DIR"/dispatcher-*.heartbeat 2>/dev/null + BEND_ENDPOINTS="$BEND_ENDPOINTS" \ + LUMBDA_DOMAIN_DIR="$LUMBDA_DOMAIN_DIR" \ + LUMBDA_BACKEND_CMD="$LUMBDA_BACKEND_CMD" \ + setsid nohup "$LUMBDA_FACTORY_DIR/bend-dispatcher.sh" \ + "$QUEUE_DIR" "$QUEUE_DIR/results.tsv" "$POOL_BATCHES" \ + >> "$QUEUE_DIR/dispatcher.log" 2>&1 < /dev/null & +} + +# DLQ runner — auto-resolves transient DLQ classes (missing-bin, +# bisect-pool-race, transient cuda-error, no-portal) and escalates the +# persistent classes to rdlq/. +DLQ_RUNNER_STALE_SEC="${DLQ_RUNNER_STALE_SEC:-180}" + +dlq_runner_alive() { + heartbeat_is_alive "$QUEUE_DIR" "dlq-runner" "$DLQ_RUNNER_STALE_SEC" +} + +restart_dlq_runner() { + log "restart bend-supervisor-dlq-runner" + LUMBDA_QUEUE_DIR="$QUEUE_DIR" \ + LUMBDA_FACTORY_DIR="$LUMBDA_FACTORY_DIR" \ + setsid nohup "$LUMBDA_FACTORY_DIR/bend-supervisor-dlq-runner.sh" \ + >> "$QUEUE_DIR/dlq-runner.log" 2>&1 < /dev/null & +} + +# ── hot-reload tunable settings ───────────────────────────────────── +# Lets operators bump POOL_MAX, BEND_ENDPOINTS, POOL_BATCHES live without +# restarting the supervisor. Drop a KEY=VALUE file at $QUEUE_DIR/supervisor.config; +# next poll iter reads it, kills affected child (pool / dispatcher), +# normal restart loop respawns with new value. +CONFIG_FILE="$QUEUE_DIR/supervisor.config" +# Fingerprint TIER_* keys so hot-reload knows when any per-tier cap or +# threshold changed. Compares concatenated env values, not file mtime, so +# unrelated edits (POOL_MAX bump alone) don't churn the dispatcher. +tier_fingerprint() { + printf '%s' \ + "${TIER_MICRO_MIN:-}|${TIER_MICRO_MAX:-}|${TIER_SMALL_MAX:-}|${TIER_MEDIUM_MAX:-}|${TIER_LARGE_MAX:-}|" \ + "${TIER_MICRO_POOL_MAX:-}|${TIER_MICRO_DISPATCH:-}|" \ + "${TIER_SMALL_POOL_MAX:-}|${TIER_SMALL_DISPATCH:-}|" \ + "${TIER_MEDIUM_POOL_MAX:-}|${TIER_MEDIUM_DISPATCH:-}|" \ + "${TIER_LARGE_POOL_MAX:-}|${TIER_LARGE_DISPATCH:-}" +} +reload_config() { + [ -f "$CONFIG_FILE" ] || return 0 + local prev_pool_max="$POOL_MAX" + local prev_endpoints="$BEND_ENDPOINTS" + local prev_batches="$POOL_BATCHES" + local prev_pool_min_bin="$POOL_MIN_BIN" + local prev_tier_fp + prev_tier_fp=$(tier_fingerprint) + # `set -a` exports every var assigned during the source so children + # (pool, dispatcher) inherit them. Without this, TIER_* + POOL_* set + # in supervisor.config stay local to this shell + dispatcher respawn + # would pick up lib-tier defaults instead of operator overrides. + set -a + # shellcheck source=/dev/null + . "$CONFIG_FILE" + set +a + local new_tier_fp + new_tier_fp=$(tier_fingerprint) + if [ "$POOL_MAX" != "$prev_pool_max" ] || [ "$POOL_MIN_BIN" != "$prev_pool_min_bin" ]; then + log "hot-reload POOL_MAX=$POOL_MAX POOL_MIN_BIN=$POOL_MIN_BIN (was MAX=$prev_pool_max MIN=$prev_pool_min_bin); killing pool, restart loop respawns" + pkill -f "bend-emit-pool.sh" 2>/dev/null + fi + # Dispatcher kill ONLY on endpoint / batches changes — tier-only + # changes flow live into workers via tier_reload_caps_from_file in + # lib-tier.sh. + if [ "$BEND_ENDPOINTS" != "$prev_endpoints" ] || [ "$POOL_BATCHES" != "$prev_batches" ]; then + log "hot-reload dispatcher config changed (killing dispatcher, restart loop respawns)" + pkill -f "bend-dispatcher.sh" 2>/dev/null + elif [ "$new_tier_fp" != "$prev_tier_fp" ]; then + log "hot-reload tier policy changed (live-reload — no dispatcher kill, workers read tier caps live)" + fi +} + +# ── main loop ─────────────────────────────────────────────────────── +while true; do + # Heartbeat first thing — supervisor must prove its own liveness too. + # factory-status reads supervisor.heartbeat to know whether a host + # has its own caretaker. + heartbeat_touch "$QUEUE_DIR" "supervisor" + reload_config + + if [ -f "$STOP_FILE" ]; then + log "STOP marker seen — exiting" + rm -f "$STOP_FILE" + SUP_EXIT_REASON="stop-marker" + break + fi + + # backend first — pool + dispatcher both need a live backend. + if ! bend_port_listening; then + log "backend DOWN on :${BEND_PORT_LISTEN}" + restart_bend + fi + + # pool + if ! pool_alive; then + n_unworked=$(count_unworked_lsp) + if [ "$n_unworked" -gt 0 ]; then + log "pool DEAD with $n_unworked un-emitted .lsp" + restart_pool + else + log "pool DEAD but queue clean — nothing to restart for" + fi + fi + + # dispatcher + if ! dispatcher_any_alive; then + n_dispatchable=$(count_dispatchable) + if [ "$n_dispatchable" -gt 0 ]; then + log "dispatcher DEAD with $n_dispatchable .ready+.bin waiting" + restart_dispatcher + else + log "dispatcher DEAD but no .ready / .bin — nothing to restart for" + fi + fi + + # DLQ runner — auto-resolve or escalate. Always restart when stale; + # cheap to run idle (scans an empty dlq/ in milliseconds). + if ! dlq_runner_alive; then + log "dlq-runner DEAD (no fresh heartbeat) — restarting" + restart_dlq_runner + fi + + sleep "$POLL_SECONDS" +done diff --git a/factory/lib-heartbeat.sh b/factory/lib-heartbeat.sh new file mode 100755 index 0000000..05d344c --- /dev/null +++ b/factory/lib-heartbeat.sh @@ -0,0 +1,108 @@ +#!/usr/bin/env bash +# lib-heartbeat.sh — shared library for factory liveness signals. +# +# Sourced by bend-emit-pool.sh, bend-dispatcher.sh, bend-supervisor.sh, +# bend-autoscaler.sh, bend-supervisor-dlq-runner.sh. Pure POSIX-ish bash; +# no external daemons; portable to busybox-bash + flock + setsid + nohup. +# +# Env vars consumed: none. See $LUMBDA_FACTORY_DIR/CONTRACT.md for full +# factory-wide knob list. +# +# Contract: +# - heartbeat_touch +# Writes " " to /.heartbeat. +# Called at top of every loop iteration; mtime + content authoritative. +# Returns 0 on success, 1 on write failure. +# +# - heartbeat_is_alive +# Returns 0 if BOTH: +# (a) heartbeat file mtime within of now +# (b) pid recorded in heartbeat file responds to kill -0 +# Returns 1 otherwise (missing file, stale mtime, dead pid). +# (a) gates daemon liveness; (b) gates against post-mortem stale files. +# +# - heartbeat_exit_cause +# Appends " " to +# /.exit-cause, removes .heartbeat. +# Caller invokes from every exit path (STOP marker, signal trap, drain +# timeout, error abort). Operators read .exit-cause to triage post-mortem. +# +# File formats: +# .heartbeat — single line: " " (whitespace-sep) +# .exit-cause — append-only log, one line per exit: +# " " +# +# Backwards compatibility: legacy per-worker dispatcher.heartbeat- +# files used freeform text content + only mtime for liveness. heartbeat_is_alive +# falls back to mtime-only when a heartbeat file does not parse as +# " ". +# +# Caller responsibilities: +# - mkdir -p "$state_dir" BEFORE calling any function (library does NOT +# auto-create; refusing to silently swallow path typos). +# - Wrap heartbeat_touch in an EXIT trap that calls heartbeat_exit_cause +# so an unexpected crash still leaves a forensic trail. + +# heartbeat_touch +heartbeat_touch() { + local state_dir="$1" + local service_name="$2" + local hb_file="${state_dir}/${service_name}.heartbeat" + printf '%s %s\n' "$$" "$(date +%s)" > "$hb_file" 2>/dev/null +} + +# heartbeat_is_alive +# Returns 0 alive, 1 dead/stale. +heartbeat_is_alive() { + local state_dir="$1" + local service_name="$2" + local threshold="$3" + local hb_file="${state_dir}/${service_name}.heartbeat" + + [ -f "$hb_file" ] || return 1 + + # mtime gate + local now mtime age + now=$(date +%s) + mtime=$(stat -c %Y "$hb_file" 2>/dev/null) || return 1 + age=$(( now - mtime )) + [ "$age" -le "$threshold" ] || return 1 + + # pid gate: parse first token. Tolerate freeform legacy content by + # treating non-numeric first token as "mtime-only mode" — return 0 if + # mtime gate already passed. + local first_token + first_token=$(awk 'NR==1 {print $1}' "$hb_file" 2>/dev/null) + if [ -z "$first_token" ]; then + return 0 + fi + case "$first_token" in + ''|*[!0-9]*) + # non-numeric (e.g., ISO timestamp from legacy writer) → mtime-only + return 0 + ;; + esac + + # Numeric pid: must respond to kill -0. Cross-host caveat: this library + # runs local to whichever process reads our heartbeat. heartbeat_is_alive + # called against a remote host's state dir over SSH must run on that + # host (kill -0 lives in local pid space only). Supervisor + status + # callers SSH per-host before calling, so this holds. + if kill -0 "$first_token" 2>/dev/null; then + return 0 + fi + return 1 +} + +# heartbeat_exit_cause +heartbeat_exit_cause() { + local state_dir="$1" + local service_name="$2" + local reason="$3" + local ec_file="${state_dir}/${service_name}.exit-cause" + local hb_file="${state_dir}/${service_name}.heartbeat" + local ts + ts=$(date -u +%FT%TZ) + printf '%s %s %s\n' "$ts" "$$" "$reason" >> "$ec_file" 2>/dev/null + rm -f "$hb_file" 2>/dev/null +} diff --git a/factory/lib-tier.sh b/factory/lib-tier.sh new file mode 100755 index 0000000..5ec80c9 --- /dev/null +++ b/factory/lib-tier.sh @@ -0,0 +1,203 @@ +#!/usr/bin/env bash +# lib-tier.sh — bin-size tier classifier + policy table. +# +# Bins sized below MIN or above MAX go to DLQ unconditionally. In-range +# bins get classified into a tier name. Each tier carries a default +# concurrency cap pair (POOL_MAX, DISPATCH) that supervisor / pool / +# dispatcher consult — overridable via $LUMBDA_QUEUE_DIR/supervisor.config +# `TIER__*` keys for hot-reload tuning. +# +# Why tiers: a backend's CPU+VRAM residency scales ~linearly with bin +# size. A 24-way fleet that fits 250-MB bins crushes a box on 2.4-GB +# bins. Per-tier admission lets a factory autopilot through a mixed +# workload without dead-zoning either extreme. +# +# Pure bash — no jq / awk / python deps, sourceable by every factory +# component. +# +# Env vars consumed: see $LUMBDA_FACTORY_DIR/CONTRACT.md for our canonical +# table. TIER_* knobs (boundaries + per-tier caps + per-tier MIB estimates) +# all readable via env override; defaults below match a 24-core / 62 GB RAM +# / 24 GB VRAM workstation profile. + +# ── tier boundaries (bytes) ────────────────────────────────────── +# A bin's tier = lowest band whose MAX it does NOT exceed. +# A bin below TIER_MICRO_MIN gets DLQ'd as "too-small" (broken emit). +# A bin above TIER_LARGE_MAX gets DLQ'd as "too-large" (would OOM a fleet). +TIER_MICRO_MIN="${TIER_MICRO_MIN:-33554432}" # 32 MB — emit-broken floor +TIER_MICRO_MAX="${TIER_MICRO_MAX:-268435456}" # 256 MB +TIER_SMALL_MAX="${TIER_SMALL_MAX:-536870912}" # 512 MB +TIER_MEDIUM_MAX="${TIER_MEDIUM_MAX:-2147483648}" # 2 GB +TIER_LARGE_MAX="${TIER_LARGE_MAX:-4294967296}" # 4 GB — co-resident ceiling +# huge tier: bins above LARGE that still fit a fleet but only when +# a card has no co-tenants. Largest candidate bins land here (6-8 GB +# observed). HUGE_MAX is "single bin needs ALL of VRAM" — our autoscaler +# must drain other tiers before dispatching huge. +# At 8 GB bin × 1.55 ratio = ~12.4 GB RSS, well under 24 GB VRAM / 62 GB +# RAM ceilings of a typical workstation when run alone. +TIER_HUGE_MAX="${TIER_HUGE_MAX:-12884901888}" # 12 GB — solo-dispatch ceiling + +# ── default concurrency caps per tier ──────────────────────────── +# Numbers tuned for a 24-core, 62 GB RAM, 24 GB VRAM workstation. +# Override via supervisor.config: TIER__POOL_MAX / TIER__DISPATCH. +# Autoscaler may rewrite these based on live RAM headroom. +TIER_MICRO_POOL_MAX="${TIER_MICRO_POOL_MAX:-24}" +TIER_MICRO_DISPATCH="${TIER_MICRO_DISPATCH:-24}" +TIER_SMALL_POOL_MAX="${TIER_SMALL_POOL_MAX:-16}" +TIER_SMALL_DISPATCH="${TIER_SMALL_DISPATCH:-16}" +TIER_MEDIUM_POOL_MAX="${TIER_MEDIUM_POOL_MAX:-12}" +TIER_MEDIUM_DISPATCH="${TIER_MEDIUM_DISPATCH:-12}" +TIER_LARGE_POOL_MAX="${TIER_LARGE_POOL_MAX:-6}" +TIER_LARGE_DISPATCH="${TIER_LARGE_DISPATCH:-6}" +# HUGE: solo-dispatch tier. Both caps = 1; one huge bin at a time. +# Autoscaler must enforce "no other tier dispatches in flight before +# admitting a huge dispatch" — cap=1 alone does not guarantee that +# (small + huge could overlap if scheduled naively). +TIER_HUGE_POOL_MAX="${TIER_HUGE_POOL_MAX:-1}" +TIER_HUGE_DISPATCH="${TIER_HUGE_DISPATCH:-1}" + +# ── per-tier per-dispatch memory estimates (MiB) ────────────────── +# Used by our autoscaler to compute "total estimated memory at current +# caps" for tier-mix admission. Calibrated from /usr/bin/time -v on a +# backend running against representative bins, scaled to each tier ceiling. +# +# Sample calibration data (peak RSS): +# 683 MB bin → 1.05 GB RSS (ratio 1.54×) → MEDIUM tier sample +# 2.4 GB bin → 3.55 GB RSS (ratio 1.48×) → LARGE tier sample +# +# CPU_MIB = tier-ceiling × 1.55× × small safety pad, so a tier-full bin +# never exceeds an admitted budget. +# MICRO ceil 256 MB × 1.55 → ~397 → round 512 +# SMALL ceil 512 MB × 1.55 → ~794 → round 1024 +# MEDIUM ceil 2 GB × 1.55 → ~3174 → round 3328 +# LARGE ceil 4 GB × 1.55 → ~6349 → round 6400 +TIER_MICRO_CPU_MIB="${TIER_MICRO_CPU_MIB:-512}" +TIER_MICRO_VRAM_MIB="${TIER_MICRO_VRAM_MIB:-512}" +TIER_SMALL_CPU_MIB="${TIER_SMALL_CPU_MIB:-1024}" +TIER_SMALL_VRAM_MIB="${TIER_SMALL_VRAM_MIB:-1024}" +TIER_MEDIUM_CPU_MIB="${TIER_MEDIUM_CPU_MIB:-3328}" +TIER_MEDIUM_VRAM_MIB="${TIER_MEDIUM_VRAM_MIB:-2048}" +TIER_LARGE_CPU_MIB="${TIER_LARGE_CPU_MIB:-6400}" +TIER_LARGE_VRAM_MIB="${TIER_LARGE_VRAM_MIB:-3072}" +# HUGE: 12 GB bin × 1.55 ratio ≈ 19000 MiB RSS at peak. Numbers below +# act as upper-bound "needs whole card" — autoscaler treats them as +# a wholesale claim, not adds-to-budget like other tiers. +TIER_HUGE_CPU_MIB="${TIER_HUGE_CPU_MIB:-19000}" +TIER_HUGE_VRAM_MIB="${TIER_HUGE_VRAM_MIB:-20480}" + +# tier_of_size BYTES → echoes one of: +# below-min bin too small; DLQ as broken emit +# micro in-band [TIER_MICRO_MIN, TIER_MICRO_MAX] +# small (TIER_MICRO_MAX, TIER_SMALL_MAX] +# medium (TIER_SMALL_MAX, TIER_MEDIUM_MAX] +# large (TIER_MEDIUM_MAX, TIER_LARGE_MAX] +# huge (TIER_LARGE_MAX, TIER_HUGE_MAX] — solo-dispatch +# above-max bin too large; DLQ as fleet overflow +tier_of_size() { + local sz="$1" + if [ -z "$sz" ] || [ "$sz" -lt "$TIER_MICRO_MIN" ] 2>/dev/null; then + echo "below-min"; return + fi + if [ "$sz" -le "$TIER_MICRO_MAX" ]; then echo "micro"; return; fi + if [ "$sz" -le "$TIER_SMALL_MAX" ]; then echo "small"; return; fi + if [ "$sz" -le "$TIER_MEDIUM_MAX" ]; then echo "medium"; return; fi + if [ "$sz" -le "$TIER_LARGE_MAX" ]; then echo "large"; return; fi + if [ "$sz" -le "$TIER_HUGE_MAX" ]; then echo "huge"; return; fi + echo "above-max" +} + +# Re-read tier caps from supervisor.config each call so autoscaler tweaks +# land in long-running dispatcher / pool workers WITHOUT a process restart. +# Old behavior baked TIER_* env at fork time → autoscaler had to kill the +# dispatcher to update caps → 30 s downtime per autoscale event. With +# live-reload, autoscaler edits supervisor.config + next tier_dispatch / +# tier_pool_max call sees a new value with no restart. +# +# Cost: sourcing a small KEY=VALUE file via grep+eval per call costs a +# few ms. tier_dispatch fires once per cell claim ≈ every 10-30 s per +# worker, so overhead stays invisible. +# +# Gated by TIER_CONFIG_LIVE_RELOAD=1 (default ON); set to 0 to fall back +# to env-only behavior (legacy / debugging). +TIER_CONFIG_FILE="${TIER_CONFIG_FILE:-${LUMBDA_QUEUE_DIR:-/tmp/lumbda-queue}/supervisor.config}" +TIER_CONFIG_LIVE_RELOAD="${TIER_CONFIG_LIVE_RELOAD:-1}" + +tier_reload_caps_from_file() { + [ "$TIER_CONFIG_LIVE_RELOAD" = "1" ] || return 0 + [ -f "$TIER_CONFIG_FILE" ] || return 0 + # Eval only TIER_* lines from a config file — never inherit + # unrelated vars (POOL_MAX etc. stay supervisor-only, change those + # via supervisor restart). + eval "$(grep -E '^TIER_[A-Z_]+=' "$TIER_CONFIG_FILE" 2>/dev/null)" +} + +# tier_pool_max NAME → echoes integer cap (0 for DLQ tiers) +tier_pool_max() { + tier_reload_caps_from_file + case "$1" in + micro) echo "$TIER_MICRO_POOL_MAX" ;; + small) echo "$TIER_SMALL_POOL_MAX" ;; + medium) echo "$TIER_MEDIUM_POOL_MAX" ;; + large) echo "$TIER_LARGE_POOL_MAX" ;; + huge) echo "$TIER_HUGE_POOL_MAX" ;; + *) echo 0 ;; + esac +} + +# tier_dispatch NAME → echoes integer cap (0 for DLQ tiers) +tier_dispatch() { + tier_reload_caps_from_file + case "$1" in + micro) echo "$TIER_MICRO_DISPATCH" ;; + small) echo "$TIER_SMALL_DISPATCH" ;; + medium) echo "$TIER_MEDIUM_DISPATCH" ;; + large) echo "$TIER_LARGE_DISPATCH" ;; + huge) echo "$TIER_HUGE_DISPATCH" ;; + *) echo 0 ;; + esac +} + +# tier_cpu_mib NAME → estimated CPU RSS per dispatch in MiB +tier_cpu_mib() { + case "$1" in + micro) echo "$TIER_MICRO_CPU_MIB" ;; + small) echo "$TIER_SMALL_CPU_MIB" ;; + medium) echo "$TIER_MEDIUM_CPU_MIB" ;; + large) echo "$TIER_LARGE_CPU_MIB" ;; + huge) echo "$TIER_HUGE_CPU_MIB" ;; + *) echo 0 ;; + esac +} + +# tier_vram_mib NAME → estimated VRAM per dispatch in MiB +tier_vram_mib() { + case "$1" in + micro) echo "$TIER_MICRO_VRAM_MIB" ;; + small) echo "$TIER_SMALL_VRAM_MIB" ;; + medium) echo "$TIER_MEDIUM_VRAM_MIB" ;; + large) echo "$TIER_LARGE_VRAM_MIB" ;; + huge) echo "$TIER_HUGE_VRAM_MIB" ;; + *) echo 0 ;; + esac +} + +# tier_solo NAME → 1 when a tier needs an empty card (no co-tenant +# dispatches); 0 when it shares a fleet with other tiers. Used by our +# autoscaler / dispatcher: before admitting a `huge` dispatch, poll all +# other tiers + verify zero inflight. lib-tier owns CLASSIFICATION; +# a controller owns ENFORCEMENT. +tier_solo() { + case "$1" in + huge) echo 1 ;; + *) echo 0 ;; + esac +} + +# tier_label_dlq NAME → reason string for DLQ (or empty if not DLQ) +tier_label_dlq() { + case "$1" in + below-min) echo "bin-too-small (under tier-micro min ${TIER_MICRO_MIN} bytes) — emit produced no usable circuit" ;; + above-max) echo "bin-too-large (over tier-huge max ${TIER_HUGE_MAX} bytes) — would exceed fleet RAM/VRAM ceiling even with solo dispatch" ;; + *) echo "" ;; + esac +} diff --git a/quantum/README.md b/quantum/README.md new file mode 100644 index 0000000..488026a --- /dev/null +++ b/quantum/README.md @@ -0,0 +1,43 @@ +# quantum/ — circuit emission primitives + +Reversible-circuit emission primitives written in lumbda Scheme: Clifford gates, ripple-carry adder (Cuccaro), modular arithmetic, modular inverse strategies, Karatsuba multiplier, Clifford tableau simulator, circuit scoring. Originally developed at foxhop for secp256k1 attack-surface research; shared upstream under AGPLv3. + +## Layers + +### Core gates + +- `gates.lsp` — Clifford gate library: `CX`, `CCX` (Toffoli), `X`. Counts Toffoli + Clifford totals as side effect for scoring. + +### Arithmetic + +- `adder.lsp` — Cuccaro ripple-carry reversible n-bit adder. Width-parametric. +- `mod-arith.lsp` — modular add/sub/cmp/neg/mul/square under `*field-prime*`. Default unset; consumer binds (foxhop sets secp256k1 `p`). +- `mod-karatsuba.lsp` — Karatsuba reversible multiplier for ⊕-bit widths. Width-parametric. + +### Modular inverse strategies + +- `mod-inv-by.lsp` — Bennett by-value-uncompute pattern (host classical `1/x`, then quantum verify-and-zero). +- `mod-inv-by-dialog-gcd.lsp` — Dialog GCD (binary extended Euclidean) reversible mod-inv. General algorithm, not field-specific. +- `mod-inv-by-dialog-gcd-host.lsp` — Host-assisted variant: classical GCD trace replayed as quantum dialog log. + +### Simulation + scoring + +- `sim.lsp` — Clifford tableau simulator. Verifies emitted circuits against expected truth tables. +- `score.lsp` — circuit metric collector. Tracks Toffoli + qubit + Clifford counts during emission. + +## Width discipline + +Every primitive width-parametric — no hardcoded `n = 256`. Consumers bind `*field-prime*`, `*width*`, and optional flags (e.g. `*mod-mul-use-karatsuba*`). + +## Hard rule — bound every loop, bound every ancilla + +- `*max-shots*` caps shot counts in sim (default 64 for dev; raise only by explicit instruction). +- Every `alloc!` call site asserts width-cap at top of caller. Unbounded growth = host hard-freeze on neoblanka (proven 2026-06-11/12). + +## Lumbda tier compatibility + +These primitives run under any lumbda tier (Python VM, C tree-walker + JIT, C + x86 JIT, pure x86 asm). Cross-tier portal validation: same `.lsp` on Python-tier + C-tier must produce byte-identical result S-expressions. Mismatch halts promotion. + +## License + +AGPLv3. diff --git a/quantum/adder.lsp b/quantum/adder.lsp new file mode 100644 index 0000000..df72f79 --- /dev/null +++ b/quantum/adder.lsp @@ -0,0 +1,2824 @@ +;;; adder.lsp — Cuccaro ripple-carry reversible n-bit adder. +;;; +;;; Phase B step 1 of the lumbda-native point-add port. +;;; +;;; Ports the upstream Rust primitives from +;;; ~/git/ecdsafail-challenge/src/point_add/mod.rs:1027..1181 +;;; +;;; MAJ(x, y, w): (cx w y) (cx w x) (ccx x y w) +;;; UMA(x, y, w): (ccx x y w) (cx w x) (cx x y) +;;; +;;; cuccaro-add!(a, acc, c-in): +;;; n = (length a) = (length acc) +;;; n=0 -> noop +;;; n=1 -> (cx c-in acc[0]) (cx a[0] acc[0]) +;;; else: +;;; Forward MAJ sweep: +;;; maj(c-in, acc[0], a[0]) +;;; for i in 1..n-1: maj(a[i-1], acc[i], a[i]) +;;; Final sum bit: +;;; cx a[n-2] acc[n-1] +;;; cx a[n-1] acc[n-1] +;;; Reverse UMA sweep: +;;; for i in (n-2)..1: uma(a[i-1], acc[i], a[i]) +;;; uma(c-in, acc[0], a[0]) +;;; +;;; Invariant: (cuccaro-add! a acc c-in) leaves +;;; acc := (acc + a) mod 2^n +;;; a := a (unchanged) +;;; c-in := 0 (uncomputed cleanly) +;;; +;;; Validation: see tests/unit/test-adder.lsp. We run the resulting +;;; circuit through sim.lsp at n in {4, 8, 16} and assert the output +;;; register equals the classical (a + b) mod 2^n. + +(load "quantum/gates.lsp") + +;;; ── MAJ + UMA primitives ─────────────────────────────────────── + +(define (maj! c x-reg x-idx y-reg y-idx w-reg w-idx) + "MAJ(x, y, w): (cx w y) (cx w x) (ccx x y w)." + (gate-cx! c w-reg w-idx y-reg y-idx) + (gate-cx! c w-reg w-idx x-reg x-idx) + (gate-ccx! c x-reg x-idx y-reg y-idx w-reg w-idx)) + +(define (uma! c x-reg x-idx y-reg y-idx w-reg w-idx) + "UMA(x, y, w): (ccx x y w) (cx w x) (cx x y)." + (gate-ccx! c x-reg x-idx y-reg y-idx w-reg w-idx) + (gate-cx! c w-reg w-idx x-reg x-idx) + (gate-cx! c x-reg x-idx y-reg y-idx)) + +;;; ── mcx3_polar + ctrl_maj family ────────────────────────────────── +;;; +;;; Port of HEAD's 3-control X with per-control polarity +;;; (arith/adder.rs:1761) plus the four controlled MAJ/UMA wrappers +;;; (lines 1804-1825) that build on it. +;;; +;;; SCOPE: default path of mcx3_polar (explicit CCX uncompute of +;;; scratch). HEAD's env-gated Gidney measured-uncompute branch (toggled +;;; by `DIALOG_GCD_CTRL_LOWQ_MEASURED=1`) saves the coherent CCX at the +;;; cost of an HMR + classical CZ correction. Deferred to a follow-up +;;; sweep — would add lumbda flag `*mcx3-polar-measured-uncompute*` +;;; defaulting `#f` (matches HEAD's env-unset default). +;;; +;;; All four `ctrl-*!` wrappers use mcx3-polar with all-positive +;;; polarities (the only callers in HEAD). Polarity arguments are kept +;;; in mcx3-polar!'s signature for full HEAD-API parity. + +(define (mcx3-polar! c c1-reg c1-idx p1 c2-reg c2-idx p2 c3-reg c3-idx p3 + target-reg target-idx scratch-reg scratch-idx) + "target ^= (c1==p1) & (c2==p2) & (c3==p3). p1/p2/p3 are scheme + booleans (#t = positive control, #f = negative-via-X-wrap). scratch + borrowed clean (|0> in/out). Default path emits ccx(c1,c2,scratch), + ccx(scratch,c3,target), then explicit ccx(c1,c2,scratch) uncompute. + HEAD's Gidney measured-uncompute branch (env-gated) deferred." + ;; X-wrap negative controls (HEAD adder.rs:1772-1780) + (cond ((not p1) (gate-x! c c1-reg c1-idx))) + (cond ((not p2) (gate-x! c c2-reg c2-idx))) + (cond ((not p3) (gate-x! c c3-reg c3-idx))) + ;; Compute scratch = c1 & c2, then target ^= scratch & c3. + (gate-ccx! c c1-reg c1-idx c2-reg c2-idx scratch-reg scratch-idx) + (gate-ccx! c scratch-reg scratch-idx c3-reg c3-idx target-reg target-idx) + ;; Default-path uncompute: re-emit the same CCX. (Gidney path would + ;; use HMR + cz_if here — deferred.) + (gate-ccx! c c1-reg c1-idx c2-reg c2-idx scratch-reg scratch-idx) + ;; X-wrap reverse — restore controls to original polarity (HEAD lines + ;; 1791-1800). + (cond ((not p3) (gate-x! c c3-reg c3-idx))) + (cond ((not p2) (gate-x! c c2-reg c2-idx))) + (cond ((not p1) (gate-x! c c1-reg c1-idx)))) + +(define (ctrl-maj! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx w-reg w-idx + scratch-reg scratch-idx) + "Controlled MAJ. When ctrl=|1>, computes maj(x, y, w) in place + (matches the uncontrolled maj!); when ctrl=|0>, no-op. Mirror of + HEAD's ctrl_maj (arith/adder.rs:1804)." + (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx y-reg y-idx) + (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx x-reg x-idx) + (mcx3-polar! c ctrl-reg ctrl-idx #t x-reg x-idx #t y-reg y-idx #t + w-reg w-idx scratch-reg scratch-idx)) + +(define (ctrl-uma! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx w-reg w-idx + scratch-reg scratch-idx) + "Controlled UMA — inverse of ctrl-maj!. Mirror of HEAD's ctrl_uma + (arith/adder.rs:1810)." + (mcx3-polar! c ctrl-reg ctrl-idx #t x-reg x-idx #t y-reg y-idx #t + w-reg w-idx scratch-reg scratch-idx) + (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx x-reg x-idx) + (gate-ccx! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx)) + +(define (ctrl-inv-maj! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx w-reg w-idx + scratch-reg scratch-idx) + "Controlled INV-MAJ — alt inverse used in HEAD's clean-MAJ blocks. + Mirror of HEAD's ctrl_inv_maj (arith/adder.rs:1816)." + (mcx3-polar! c ctrl-reg ctrl-idx #t x-reg x-idx #t y-reg y-idx #t + w-reg w-idx scratch-reg scratch-idx) + (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx x-reg x-idx) + (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx y-reg y-idx)) + +(define (ctrl-inv-uma! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx w-reg w-idx + scratch-reg scratch-idx) + "Controlled INV-UMA. Mirror of HEAD's ctrl_inv_uma + (arith/adder.rs:1822)." + (gate-ccx! c ctrl-reg ctrl-idx x-reg x-idx y-reg y-idx) + (gate-ccx! c ctrl-reg ctrl-idx w-reg w-idx x-reg x-idx) + (mcx3-polar! c ctrl-reg ctrl-idx #t x-reg x-idx #t y-reg y-idx #t + w-reg w-idx scratch-reg scratch-idx)) + +;;; ── Cuccaro ripple-carry adder ───────────────────────────────── + +(define (cuccaro-add! c a-reg acc-reg cin-reg cin-idx n) + "Emit gates implementing acc := (acc + a) mod 2^n. + Requires (= n (register-width a-reg) (register-width acc-reg)). + cin-reg[cin-idx] starts |0>, ends |0>." + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c cin-reg cin-idx acc-reg 0) + (gate-cx! c a-reg 0 acc-reg 0)) + (else + ;; Forward MAJ sweep + (maj! c cin-reg cin-idx acc-reg 0 a-reg 0) + (let loop ((i 1)) + (when (< i (- n 1)) + (maj! c a-reg (- i 1) acc-reg i a-reg i) + (loop (+ i 1)))) + ;; Final sum bit + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + ;; Reverse UMA sweep + (let loop ((i (- n 2))) + (when (>= i 1) + (uma! c a-reg (- i 1) acc-reg i a-reg i) + (loop (- i 1)))) + (uma! c cin-reg cin-idx acc-reg 0 a-reg 0)))) + +;;; ── HEAD fast variant: HMR-uncompute carries ───────────────────── +;;; +;;; Port of HEAD's `cuccaro_add_fast` (mod.rs:1042-1092) + +;;; `cuccaro_sub_fast` (mod.rs:1658-1707). Allocates explicit carry +;;; ancillas + replaces UMA-CCX backward uncompute with HMR + push-cond + +;;; CZ + pop-cond per bit. Saves (n-1) Toffoli per call (0-Toffoli +;;; backward sweep per HEAD's design). +;;; +;;; Caller responsibility: provide `carries-name` register pre-allocated +;;; to width n-1 + clean (|0>); + a `bit-base` integer for classical bit +;;; IDs. The function uses bit IDs bit-base .. bit-base+n-2. + +(define (cuccaro-add-fast! c a-reg acc-reg cin-reg cin-idx n + carries-name bit-base) + "Same algebra as cuccaro-add! but with HMR carry uncompute. + Pre: carries-name register (width n-1) allocated by caller, all |0>. + Post: carries-name returns to |0>; a-reg + cin-reg unchanged; + acc-reg := (acc + a) mod 2^n. + + sweep-056: when (and *apply-phase-architecture* *cuccaro-vented*) + is #t, dispatch into cuccaro-add-fast-vented!." + (cond + ((and *cuccaro-vented* *apply-phase-architecture*) + (cuccaro-add-fast-vented! c a-reg acc-reg cin-reg cin-idx n + carries-name bit-base)) + ((= n 0) #t) + ((= n 1) + (gate-cx! c cin-reg cin-idx acc-reg 0) + (gate-cx! c a-reg 0 acc-reg 0)) + (else + ;; Forward sweep — MAJ-like with explicit carries + (gate-cx! c a-reg 0 acc-reg 0) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-name 0) + (gate-cx! c carries-name 0 a-reg 0) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg i acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i carries-name i) + (gate-cx! c carries-name i a-reg i) + (loop-fwd (+ i 1)))) + ;; Final sum bit + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + ;; Backward HMR uncompute sweep (0 Toffoli) + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-name i a-reg i) + (gate-hmr! c carries-name i (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg (- i 1) acc-reg i) + (loop-back (- i 1)))) + ;; Step 0 backward + (gate-cx! c carries-name 0 a-reg 0) + (gate-hmr! c carries-name 0 bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg 0) + (gate-pop-cond! c) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-cx! c cin-reg cin-idx acc-reg 0)))) + +(define (cuccaro-sub-fast! c a-reg acc-reg cin-reg cin-idx n + carries-name bit-base) + "Same as cuccaro-add-fast! but: acc := (acc - a - cin) mod 2^n. + Mirrors HEAD's cuccaro_sub_fast (mod.rs:1658-1707). + + sweep-056: vented dispatch on (and *apply-phase-architecture* + *cuccaro-vented*) #t." + (cond + ((and *cuccaro-vented* *apply-phase-architecture*) + (cuccaro-sub-fast-vented! c a-reg acc-reg cin-reg cin-idx n + carries-name bit-base)) + ((= n 0) #t) + ((= n 1) + (gate-cx! c a-reg 0 acc-reg 0) + (gate-cx! c cin-reg cin-idx acc-reg 0)) + (else + ;; Forward inv_UMA sweep + (gate-cx! c cin-reg cin-idx acc-reg 0) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-name 0) + (gate-cx! c carries-name 0 a-reg 0) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg (- i 1) acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i carries-name i) + (gate-cx! c carries-name i a-reg i) + (loop-fwd (+ i 1)))) + ;; Final sum bit + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + ;; Backward inv_MAJ HMR uncompute sweep + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-name i a-reg i) + (gate-hmr! c carries-name i (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg i acc-reg i) + (loop-back (- i 1)))) + ;; Step 0 backward + (gate-cx! c carries-name 0 a-reg 0) + (gate-hmr! c carries-name 0 bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg 0) + (gate-pop-cond! c) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-cx! c a-reg 0 acc-reg 0)))) + +;;; *cuccaro-use-fast* — substrate flag. When #t, ctrl-cuccaro-*-hosted! +;;; (mod-inv-by-dialog-gcd-host.lsp) dispatches to cuccaro-{add,sub}-fast! +;;; instead of cuccaro-{add,sub}! for the inner ops. Caller must +;;; pre-allocate carries register + reserve bit-id range. + +(define *cuccaro-use-fast* #f) + +;;; *cuccaro-vented* — sweep-056 apply-phase retrofit flag. +;;; +;;; When BOTH *apply-phase-architecture* AND *cuccaro-vented* are #t, +;;; cuccaro-{add,sub}-fast! & cuccaro-{add,sub}-fast-borrowed! dispatch +;;; into apply-phase-aware vented variants (defined at end of this file). +;;; The vented variants exercise the sweep-054 substrate by wrapping each +;;; call in a begin-apply-phase! / end-apply-phase! scope pair & sourcing +;;; vent-key BitIds from apply-phase-bit-next (the substrate's global +;;; allocator at 1,000,000+) instead of the caller-supplied bit-base. +;;; +;;; Algorithmic note (per sweep-056 analysis): the legacy backward +;;; uncompute sweep already emits per-iter (hmr + push-cond + cz + pop-cond) +;;; which IS the venting wire pattern. Each iter's CZ_if acts on +;;; (a[i-1], acc[i]) — operand qubits that subsequent iters MUTATE via +;;; cx a[i] -> a[i-1] & cx a[i-1] -> acc[i] before sweep end. Deferring +;;; the CZ_if to a post-sweep broadcast would therefore use stale operand +;;; values & break correctness. The vented first-cut consequently keeps +;;; the per-iter wire pattern intact but routes vent-key allocation +;;; through the substrate — exercising begin/end scope discipline + +;;; bit-allocator state-machine. Downstream peak-qubits win requires +;;; restructuring the carries lane (HEAD venting.rs:147-309 ripples on 2 +;;; clean ancillas instead of n-1) which exceeds the constraint of this +;;; sweep (adder.lsp-only, no caller surgery). +;;; +;;; When *apply-phase-architecture* is #f (default), this flag is inert +;;; even if set #t — the vented path checks the architecture flag first. + +(define *cuccaro-vented* #f) + +;;; ── HEAD borrowed-carries variant — overlay carries on caller's free ancilla ─ +;;; +;;; Port of HEAD's `cuccaro_add_fast_borrowed_carries` (mod.rs:1097-1144) + +;;; `cuccaro_sub_fast_borrowed_carries` (mirror). Same gate sequence as the +;;; -fast! variant but the carries lane is BORROWED from a caller-supplied +;;; register at the given offset. The HMR uncompute returns carries to +;;; clean |0> so caller's register is unchanged at exit. +;;; +;;; HEAD comment line 1095: "Kaliski step4 can reuse clean high `tmp` lanes +;;; without increasing peak Q." Our equivalent: ctrl-cuccaro-*-hosted! +;;; passes mod-inv-by-dialog-gcd-host!'s tmp register as the carries source +;;; — tmp is free during STEP 4 (used only by mod-double-inplace! at STEP 7+8). + +(define (cuccaro-add-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n + carries-reg carries-offset bit-base) + "Same as cuccaro-add-fast! but carries are borrowed from + carries-reg starting at carries-offset (uses n-1 slots). + carries-reg[carries-offset..carries-offset+n-2] must be |0> + on entry; HMR uncompute returns them to |0> on exit. + + sweep-056: vented dispatch on (and *apply-phase-architecture* + *cuccaro-vented*) #t." + (cond + ((and *cuccaro-vented* *apply-phase-architecture*) + (cuccaro-add-fast-borrowed-vented! c a-reg acc-reg cin-reg cin-idx n + carries-reg carries-offset bit-base)) + ((= n 0) #t) + ((= n 1) + (gate-cx! c cin-reg cin-idx acc-reg 0) + (gate-cx! c a-reg 0 acc-reg 0)) + (else + (gate-cx! c a-reg 0 acc-reg 0) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg 0) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg i acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (loop-fwd (+ i 1)))) + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg (- i 1) acc-reg i) + (loop-back (- i 1)))) + (gate-cx! c carries-reg carries-offset a-reg 0) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg 0) + (gate-pop-cond! c) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-cx! c cin-reg cin-idx acc-reg 0)))) + +(define (cuccaro-add-fast-borrowed-no-cin! c a-reg acc-reg n + carries-reg carries-offset bit-base) + "acc += a mod 2^n with c_in PROVEN |0> by the caller. Mirrors HEAD's + cuccaro_add_fast_borrowed_carries_no_cin (arith/adder.rs:1184). + Same algebra as cuccaro-add-fast-borrowed! with the c_in qubit folded + out — saves the 4 cin-touching CX gates (2 forward, 2 reverse) and + means the caller doesn't need to alloc a c_in ancilla at all. + carries-reg[carries-offset..carries-offset+n-2] must be |0> on entry; + HMR uncompute returns them to |0> on exit. + + Per HEAD's comment at adder.rs:1218-1228: the trailing reverse-step + pattern `cz_if(c_in,acc[0],m0); cx(a[0],c_in); cx(c_in,acc[0])` of + the c_in form collapses to a single `cz_if(a[0],acc[0],m0)` here + because (1) `cx(carries[0],a[0])` just restored a[0] to the frozen + c_in value so cz_if on a[0] == cz_if on c_in, and (2) the two + trailing CXs reset c_in (now |0>) and then cx c_in into acc (no-op + on |0>) — both drop out." + (cond + ((= n 0) #t) + ((= n 1) + ;; Pure XOR — no carry lane needed when c_in == 0. + (gate-cx! c a-reg 0 acc-reg 0)) + (else + ;; Step 0 forward (cin folded out — a[0] takes its place as the + ;; ccx control after the seed cx). + (gate-cx! c a-reg 0 acc-reg 0) + (gate-ccx! c a-reg 0 acc-reg 0 carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg 0) + ;; Forward sweep [1..n-1) — unchanged from cuccaro-add-fast-borrowed! + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg i acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (loop-fwd (+ i 1)))) + ;; Top sum — unchanged. + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + ;; Backward HMR sweep [1..n-1) reverse — unchanged. + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg (- i 1) acc-reg i) + (loop-back (- i 1)))) + ;; Step 0 reverse — c_in folded out: just unwind carry[0] + cz_if + ;; on a[0] (a[0] still carries the c_in value at this point because + ;; the immediately-preceding `cx(carries[0],a[0])` restored it). + ;; No trailing `cx(a[0],c_in)` + `cx(c_in,acc[0])` pair — see + ;; docstring. + (gate-cx! c carries-reg carries-offset a-reg 0) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c a-reg 0 acc-reg 0) + (gate-pop-cond! c)))) + +(define (cuccaro-sub-fast-borrowed-no-cin! c a-reg acc-reg n + carries-reg carries-offset bit-base) + "acc -= a mod 2^n with c_in PROVEN |0>. Mirrors HEAD's + cuccaro_sub_fast_borrowed_carries_no_cin (arith/adder.rs:1241). + Same algebra as cuccaro-sub-fast-borrowed! with c_in folded out by + exactly the same pattern as the add direction; see + cuccaro-add-fast-borrowed-no-cin! docstring for the algebra rationale." + (cond + ((= n 0) #t) + ((= n 1) + ;; Pure XOR (subtraction mod 2 == addition mod 2 for the single + ;; bit case; c_in == 0 collapses the cin-fed CX away). + (gate-cx! c a-reg 0 acc-reg 0)) + (else + ;; Step 0 forward (cin folded out, a[0] takes its place). + (gate-ccx! c a-reg 0 acc-reg 0 carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg 0) + ;; Forward sweep [1..n-1) — unchanged from cuccaro-sub-fast-borrowed! + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg (- i 1) acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (loop-fwd (+ i 1)))) + ;; Top sum. + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + ;; Backward HMR sweep [1..n-1) reverse. + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg i acc-reg i) + (loop-back (- i 1)))) + ;; Step 0 reverse — c_in folded out. + (gate-cx! c carries-reg carries-offset a-reg 0) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c a-reg 0 acc-reg 0) + (gate-pop-cond! c) + ;; Final acc XOR with a[0] in the sub direction — preserved from + ;; cuccaro-sub-fast-borrowed!'s sub-direction tail (the cin form + ;; ended with `cx(a[0],acc[0])` after the cz_if + reset triple, + ;; and the reset triple drops out per the no-cin algebra but the + ;; standalone `cx(a[0],acc[0])` stays because sub's algebra + ;; requires it independently of c_in folding). + (gate-cx! c a-reg 0 acc-reg 0)))) + +(define (cuccaro-sub-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n + carries-reg carries-offset bit-base) + "Same as cuccaro-sub-fast! but carries borrowed from carries-reg. + + sweep-056: vented dispatch on (and *apply-phase-architecture* + *cuccaro-vented*) #t." + (cond + ((and *cuccaro-vented* *apply-phase-architecture*) + (cuccaro-sub-fast-borrowed-vented! c a-reg acc-reg cin-reg cin-idx n + carries-reg carries-offset bit-base)) + ((= n 0) #t) + ((= n 1) + (gate-cx! c a-reg 0 acc-reg 0) + (gate-cx! c cin-reg cin-idx acc-reg 0)) + (else + (gate-cx! c cin-reg cin-idx acc-reg 0) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg 0) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg (- i 1) acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (loop-fwd (+ i 1)))) + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg i acc-reg i) + (loop-back (- i 1)))) + (gate-cx! c carries-reg carries-offset a-reg 0) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg 0) + (gate-pop-cond! c) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-cx! c a-reg 0 acc-reg 0)))) + +;;; *cuccaro-use-borrowed* — when #t, ctrl-cuccaro-*-hosted! uses the +;;; cuccaro-fast-borrowed variants with tmp-reg as the carries source. +;;; ZERO peak qubit cost (tmp is already allocated by caller). + +(define *cuccaro-use-borrowed* #f) + +;;; ── sweep-cuccaro-lane-vector — multi-source borrow primitive ────── +;;; +;;; Port of HEAD's `dialog_gcd_build_composite_scratch` lane vector +;;; (compressed.rs:362-435). HEAD's body-scratch borrow is a `Vec` +;;; collected from MULTIPLE source slices (future-carry, current-block +;;; compressed cells, u-high, v-high). When `DIALOG_GCD_BORROW_CURRENT_BLOCK` +;;; fires (compressed.rs:416-427), the current block's own compressed cells +;;; are folded into the lanes — a pure qubit relabel that shrinks the +;;; body-scratch deficit. +;;; +;;; Lumbda's existing `cuccaro-*-fast-borrowed!` accepts a SINGLE +;;; `(carries-reg, carries-offset)` source: carry slot `i` resolves to +;;; `(carries-reg, carries-offset + i)`. The lane-vector primitive +;;; widens that signature: carry slot `i` resolves through a list of +;;; `(reg offset width)` triples, walking lanes left-to-right. +;;; +;;; Backward compatibility: a lane vector of `((carries-reg carries-offset (- n 1)))` +;;; produces a BYTE-IDENTICAL gate sequence to the single-source variant +;;; (proven by construction — see `cuccaro-lane-resolve` below). +;;; +;;; Lane-vector format: a list of triples `(reg offset width)` where +;;; - reg is a register name (symbol or string) +;;; - offset is the starting bit index within reg +;;; - width is the number of |0> carry slots this lane contributes +;;; Total width across lanes MUST be >= n-1. Each lane's slice +;;; reg[offset..offset+width] MUST be |0> on entry; the HMR uncompute +;;; restores all lanes to |0> on exit (each lane bit is HMR'd via +;;; bit-base + global-carry-index, so HMR classical bit IDs stay +;;; sequential exactly like the single-source variant). +;;; +;;; `cuccaro-lane-resolve` translates a global carry index `i` ∈ [0, n-1) +;;; to a `(reg . offset)` pair by walking lane-vec. Total Toffoli / +;;; Clifford / HMR-bit counts are IDENTICAL to single-source — only +;;; the qubit IDs the gates touch change. + +(define (cuccaro-lane-resolve lane-vec global-i) + "Walk lane-vec to find the (reg . offset) for global carry index + global-i. Returns a pair (reg . offset). Errors if global-i exceeds + total lane width." + (let loop ((lanes lane-vec) (remaining global-i)) + (cond + ((null? lanes) + (error "cuccaro-lane-resolve: carry index out of lane-vec total width")) + (else + (let* ((lane (car lanes)) + (l-reg (car lane)) + (l-off (car (cdr lane))) + (l-w (car (cdr (cdr lane))))) + (cond + ((< remaining l-w) + (cons l-reg (+ l-off remaining))) + (else + (loop (cdr lanes) (- remaining l-w))))))))) + +(define (cuccaro-lane-total-width lane-vec) + "Sum widths across lane-vec." + (let loop ((lanes lane-vec) (acc 0)) + (cond + ((null? lanes) acc) + (else + (loop (cdr lanes) (+ acc (car (cdr (cdr (car lanes)))))))))) + +;; Sentinel: lane primitives loaded +(define *cuccaro-lane-vector-loaded* #t) + +(define (cuccaro-add-fast-borrowed-lane! c a-reg acc-reg cin-reg cin-idx n + lane-vec bit-base) + "Multi-source variant of cuccaro-add-fast-borrowed!. Carries are + borrowed from a lane vector (list of `(reg offset width)` triples) + instead of a single (carries-reg, carries-offset) source. Total + lane-width must be >= n-1. + + Each lane's slice reg[offset..offset+width] must be |0> on entry; + HMR uncompute restores all to |0> on exit. Consumes n-1 HMR + classical bit IDs (bit-base..bit-base+n-2), identical to the + single-source variant. + + Backward compat: passing `((reg off (- n 1)))` produces a gate stream + byte-identical to cuccaro-add-fast-borrowed! at (reg, off)." + (when (< (cuccaro-lane-total-width lane-vec) (- n 1)) + (error "cuccaro-add-fast-borrowed-lane!: lane-vec total width < n-1")) + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c cin-reg cin-idx acc-reg 0) + (gate-cx! c a-reg 0 acc-reg 0)) + (else + ;; Step 0 forward — lane slot 0 + (let* ((slot0 (cuccaro-lane-resolve lane-vec 0)) + (s0-reg (car slot0)) + (s0-off (cdr slot0))) + (gate-cx! c a-reg 0 acc-reg 0) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg 0 s0-reg s0-off) + (gate-cx! c s0-reg s0-off a-reg 0)) + ;; Forward sweep i in [1, n-1) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (let* ((slot (cuccaro-lane-resolve lane-vec i)) + (s-reg (car slot)) + (s-off (cdr slot))) + (gate-cx! c a-reg i acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i s-reg s-off) + (gate-cx! c s-reg s-off a-reg i)) + (loop-fwd (+ i 1)))) + ;; Top sum capture + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + ;; Backward HMR uncompute sweep, n-1 iters + (let loop-back ((i (- n 2))) + (when (>= i 1) + (let* ((slot (cuccaro-lane-resolve lane-vec i)) + (s-reg (car slot)) + (s-off (cdr slot))) + (gate-cx! c s-reg s-off a-reg i) + (gate-hmr! c s-reg s-off (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg (- i 1) acc-reg i)) + (loop-back (- i 1)))) + ;; Step 0 backward + (let* ((slot0 (cuccaro-lane-resolve lane-vec 0)) + (s0-reg (car slot0)) + (s0-off (cdr slot0))) + (gate-cx! c s0-reg s0-off a-reg 0) + (gate-hmr! c s0-reg s0-off bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg 0) + (gate-pop-cond! c) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-cx! c cin-reg cin-idx acc-reg 0))))) + +(define (cuccaro-sub-fast-borrowed-lane! c a-reg acc-reg cin-reg cin-idx n + lane-vec bit-base) + "Multi-source variant of cuccaro-sub-fast-borrowed!. Mirror of + cuccaro-add-fast-borrowed-lane! with sub algebra. Same lane-vec + conventions; same n-1 HMR bit IDs consumed." + (when (< (cuccaro-lane-total-width lane-vec) (- n 1)) + (error "cuccaro-sub-fast-borrowed-lane!: lane-vec total width < n-1")) + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c a-reg 0 acc-reg 0) + (gate-cx! c cin-reg cin-idx acc-reg 0)) + (else + ;; Step 0 forward + (let* ((slot0 (cuccaro-lane-resolve lane-vec 0)) + (s0-reg (car slot0)) + (s0-off (cdr slot0))) + (gate-cx! c cin-reg cin-idx acc-reg 0) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg 0 s0-reg s0-off) + (gate-cx! c s0-reg s0-off a-reg 0)) + ;; Forward sweep + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (let* ((slot (cuccaro-lane-resolve lane-vec i)) + (s-reg (car slot)) + (s-off (cdr slot))) + (gate-cx! c a-reg (- i 1) acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i s-reg s-off) + (gate-cx! c s-reg s-off a-reg i)) + (loop-fwd (+ i 1)))) + ;; Top borrow capture + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + ;; Backward HMR uncompute sweep + (let loop-back ((i (- n 2))) + (when (>= i 1) + (let* ((slot (cuccaro-lane-resolve lane-vec i)) + (s-reg (car slot)) + (s-off (cdr slot))) + (gate-cx! c s-reg s-off a-reg i) + (gate-hmr! c s-reg s-off (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg i acc-reg i)) + (loop-back (- i 1)))) + ;; Step 0 backward + (let* ((slot0 (cuccaro-lane-resolve lane-vec 0)) + (s0-reg (car slot0)) + (s0-off (cdr slot0))) + (gate-cx! c s0-reg s0-off a-reg 0) + (gate-hmr! c s0-reg s0-off bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg 0) + (gate-pop-cond! c) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-cx! c a-reg 0 acc-reg 0))))) + +;;; *cuccaro-use-borrowed-lane* — when #t, ctrl-cuccaro-*-hosted! uses +;;; the lane-vector primitives instead of the single-source borrowed +;;; variants. The lane vector is supplied via *cuccaro-lane-vector-thunk* +;;; — a thunk evaluated at each callsite that returns the current +;;; lane vector (lets callers build per-iter / per-call lane vectors +;;; from currently-allocated borrow sources). +;;; +;;; Default `#f` keeps the single-source path active → byte-identity +;;; with champion preserved. When `#t` AND *cuccaro-use-borrowed* is +;;; also `#t` (so the borrowed path is selected), the lane-vector +;;; primitive fires; single-source callers degrade to a one-lane vec +;;; produced by the default thunk for byte-identity. + +(define *cuccaro-use-borrowed-lane* #f) + +;; Default thunk: builds a one-lane vector covering the entire single- +;; source (tmp-borrow) carries region. Caller sets this to a custom +;; thunk to inject multi-source lanes (e.g. tmp-borrow + block-k +;; compressed cells). +;; +;; Thunk signature: (lambda (n tmp-name) lane-vector) — receives the +;; adder width n and the legacy tmp-borrow register name; returns a +;; lane-vec list of (reg offset width) triples with total width >= n-1. +(define (cuccaro-lane-default-thunk n tmp-name) + (list (list tmp-name 0 (- n 1)))) + +(define *cuccaro-lane-vector-thunk* cuccaro-lane-default-thunk) + +;;; ── HEAD specialization: cuccaro-add when acc is |0> on entry ───── +;;; +;;; Port of HEAD's `mod_add_qq_fast_from_zero` first-add specialization +;;; (mod.rs:961-1038). When the accumulator is provably |0> on entry, +;;; (acc + a) mod 2^n simplifies to a; the full Cuccaro adder reduces +;;; to n CX-copies of a into acc. Saves n-1 CCX per call vs the n-1 +;;; MAJs in cuccaro-add!, & matches HEAD's lines 970-972 verbatim. +;;; +;;; Caller responsibility: acc-reg MUST be |0> on entry across all n +;;; bits. cin-reg unused (mirrors HEAD: no carry-in concept when both +;;; addends start at zero — cin would just leak into acc[0] as a CX). +;;; Pre/post: a-reg unchanged; acc-reg := a on exit. +;;; +;;; cin-reg/cin-idx parameters retained for signature parity with +;;; cuccaro-add! so the call sites in mod-add-from-zero! / mod-mul- +;;; solinas-from-zero! stay uniform. + +(define (cuccaro-add-from-zero! c a-reg acc-reg cin-reg cin-idx n) + "acc := a (mod 2^n) when acc is |0> on entry. n CX-copies, 0 CCX. + cin-reg/cin-idx ignored (HEAD's specialization has no carry-in slot)." + (let loop ((i 0)) + (when (< i n) + (gate-cx! c a-reg i acc-reg i) + (loop (+ i 1))))) + +;;; ── HEAD low-to-ext family: source width n, acc width n+1 ───────── +;;; +;;; Port of HEAD's `cuccaro_add_fast_low_to_ext` (mod.rs:1711-1750) + +;;; `cuccaro_sub_fast_low_to_ext` (mod.rs:1754-1793). Same algebra as +;;; the non-ext fast variants but the accumulator is one bit wider than +;;; the source — the top sum bit (carry-out) is written into acc[n] +;;; instead of being discarded. +;;; +;;; Per HEAD's design, carries lane is internally caller-supplied (we +;;; expose carries-name + bit-base so the offset-aware windowed wrapper +;;; can drive these from a parent scope). carries width MUST be n. +;;; HMR bit IDs consumed: n (indices bit-base..bit-base+n-1). +;;; +;;; a-off and acc-off are starting indices into a-reg and acc-reg +;;; respectively — pass 0 for the default standalone call; the +;;; windowed top-level passes lo for per-block dispatch. + +;;; ── cuccaro-add-low-to-ext-clean! + cuccaro-sub-low-to-ext-clean! ── +;;; +;;; Port of HEAD cuccaro_add_low_to_ext_clean (adder.rs:208-238) + +;;; cuccaro_sub_low_to_ext_clean (adder.rs:240-271), commit 2dcf00d. +;;; "Clean" variants: full n-step MAJ forward + UMA backward sweep, +;;; NO HMR, NO carry-lane ancilla -- "safe inside emit_inverse blocks" +;;; per HEAD's docstring. Materializes the carry-out into +;;; acc-ext[n] (the extension bit) via CX after the forward sweep. +;;; +;;; Substrate status: ADDITIVE. No lumbda caller dispatches through +;;; either primitive yet. Closes §1.1 ABSENT rows 7+8 (the last two +;;; ABSENT rows in §1.1 — the Cuccaro family now has full primitive +;;; coverage per HEAD-PARITY-COLLAB). +;;; +;;; Algorithm (HEAD lines 208-238): +;;; 1. maj(c_in, acc[0], a[0]) +;;; 2. for i=1..n-1: maj(a[i-1], acc[i], a[i]) +;;; 3. cx(a[n-1], acc[n]) -- carry-out into ext bit +;;; 4. for i=n-1..1: uma(a[i-1], acc[i], a[i]) +;;; 5. uma(c_in, acc[0], a[0]) +;;; +;;; a-reg + cin-reg preserved across the call (carry chain closes back +;;; to entry state); acc-ext-reg gets sum + carry-out. n=0 is a +;;; clean no-op except CX(c_in, acc[0]) per HEAD's degenerate path. +;;; +;;; Sub-clean uses inv-uma!/inv-maj! and reverses the sweep order; +;;; the CX(a[n-1], acc[n]) sits in the middle, self-inverse. + +(define (cuccaro-add-low-to-ext-clean! + c a-reg acc-ext-reg n cin-reg cin-idx) + ;; acc-ext := (a + acc-ext + cin); a-reg width >= n; + ;; acc-ext-reg width >= n+1. a + cin restored. + (cond + ((= n 0) + (gate-cx! c cin-reg cin-idx acc-ext-reg 0)) + (else + (maj! c cin-reg cin-idx acc-ext-reg 0 a-reg 0) + (let loop ((i 1)) + (when (< i n) + (maj! c a-reg (- i 1) acc-ext-reg i a-reg i) + (loop (+ i 1)))) + (gate-cx! c a-reg (- n 1) acc-ext-reg n) + (let loop-back ((i (- n 1))) + (when (>= i 1) + (uma! c a-reg (- i 1) acc-ext-reg i a-reg i) + (loop-back (- i 1)))) + (uma! c cin-reg cin-idx acc-ext-reg 0 a-reg 0)))) + +(define (cuccaro-sub-low-to-ext-clean! + c a-reg acc-ext-reg n cin-reg cin-idx) + ;; acc-ext := (acc-ext - (a + cin)). Per HEAD lines 240-271: same + ;; carry identity under the running ext bit; uses inv_uma + inv_maj. + (cond + ((= n 0) + (gate-cx! c cin-reg cin-idx acc-ext-reg 0)) + (else + (inv-uma! c cin-reg cin-idx acc-ext-reg 0 a-reg 0) + (let loop ((i 1)) + (when (< i n) + (inv-uma! c a-reg (- i 1) acc-ext-reg i a-reg i) + (loop (+ i 1)))) + (gate-cx! c a-reg (- n 1) acc-ext-reg n) + (let loop-back ((i (- n 1))) + (when (>= i 1) + (inv-maj! c a-reg (- i 1) acc-ext-reg i a-reg i) + (loop-back (- i 1)))) + (inv-maj! c cin-reg cin-idx acc-ext-reg 0 a-reg 0)))) + +(define (cuccaro-add-fast-low-to-ext! c + a-reg a-off + acc-reg acc-off + cin-reg cin-idx + n + carries-reg carries-offset + bit-base) + "acc-ext := (acc-ext + a + cin) mod 2^(n+1). + a-reg slice : a-reg[a-off..a-off+n] (source, width n) + acc-reg slice: acc-reg[acc-off..acc-off+n+1] (extended, width n+1) + Top sum bit (carry-out) lands at acc-reg[acc-off+n]. + carries-reg[carries-offset..carries-offset+n-1] must be |0> entry/exit. + Consumes n HMR classical bit IDs (bit-base..bit-base+n-1)." + (cond + ((= n 0) + (gate-cx! c cin-reg cin-idx acc-reg acc-off)) + (else + ;; Forward sweep — n carries (one per source bit) + (gate-cx! c a-reg a-off acc-reg acc-off) + (gate-cx! c a-reg a-off cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg acc-off carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg a-off) + (let loop-fwd ((i 1)) + (when (< i n) + (gate-cx! c a-reg (+ a-off i) acc-reg (+ acc-off i)) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-ccx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg (+ a-off i)) + (loop-fwd (+ i 1)))) + ;; Top sum bit captured into the extended slot acc[n] + (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off n)) + ;; Backward HMR uncompute sweep (n-1 iters) + (let loop-back ((i (- n 1))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) + a-reg (+ a-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) + (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i)) + (gate-pop-cond! c) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-cx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i)) + (loop-back (- i 1)))) + ;; Step 0 backward + (gate-cx! c carries-reg carries-offset a-reg a-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg acc-off) + (gate-pop-cond! c) + (gate-cx! c a-reg a-off cin-reg cin-idx) + (gate-cx! c cin-reg cin-idx acc-reg acc-off)))) + +(define (cuccaro-sub-fast-low-to-ext! c + a-reg a-off + acc-reg acc-off + cin-reg cin-idx + n + carries-reg carries-offset + bit-base) + "acc-ext := (acc-ext - a - cin) mod 2^(n+1). Mirror of + cuccaro-add-fast-low-to-ext! — carries-reg + bit-base usage identical. + Consumes n HMR classical bit IDs." + (cond + ((= n 0) + (gate-cx! c cin-reg cin-idx acc-reg acc-off)) + (else + ;; Forward inv-UMA sweep + (gate-cx! c cin-reg cin-idx acc-reg acc-off) + (gate-cx! c a-reg a-off cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg acc-off carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg a-off) + (let loop-fwd ((i 1)) + (when (< i n) + (gate-cx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i)) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-ccx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg (+ a-off i)) + (loop-fwd (+ i 1)))) + ;; Top borrow bit captured into the extended slot acc[n] + (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off n)) + ;; Backward HMR uncompute sweep + (let loop-back ((i (- n 1))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) + a-reg (+ a-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) + (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i)) + (gate-pop-cond! c) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-cx! c a-reg (+ a-off i) acc-reg (+ acc-off i)) + (loop-back (- i 1)))) + ;; Step 0 backward + (gate-cx! c carries-reg carries-offset a-reg a-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg acc-off) + (gate-pop-cond! c) + (gate-cx! c a-reg a-off cin-reg cin-idx) + (gate-cx! c a-reg a-off acc-reg acc-off)))) + +;;; ── low-to-ext borrowed-carries c_in-folded-out variants ────────── +;;; +;;; Ports of HEAD's `cuccaro_{add,sub}_fast_low_to_ext_borrowed_carries_no_cin` +;;; (`src/point_add/arith/adder.rs:631` + `:680`, commit 2dcf00d). Same +;;; algebra as the c_in form (cuccaro-{add,sub}-fast-low-to-ext!) with +;;; the c_in qubit folded out — saves 1 c_in ancilla + 4 trailing/leading +;;; CX gates per call when the caller proves c_in == |0>. +;;; +;;; SCOPE: ports the DEFAULT path only (HEAD's `gate_suffix` from +;;; `square_selfhost_gate_suffix_carries(n)` defaults to 0 via env var +;;; `SQUARE_SELFHOST_GATE_SUFFIX_CARRIES`). With gate_suffix=0 the +;;; hybrid borrowed/clean-MAJ scheme degenerates to pure borrowed-carries +;;; (the `for i in borrowed..n` clean-MAJ loops are empty). Hybrid scheme +;;; (env-driven gate_suffix > 0; lowers peak qubit by gate_suffix at the +;;; cost of extra Toffoli) is a separate future port — would add a +;;; lumbda flag `*cuccaro-low-ext-gate-suffix-carries*` and the maj/ +;;; uma-fed clean-MAJ block. Worth doing when a lumbda caller materializes +;;; that wants the peak-qubit tradeoff. + +(define (cuccaro-add-fast-low-to-ext-borrowed-no-cin! + c a-reg a-off acc-reg acc-off n + carries-reg carries-offset bit-base) + "acc[acc-off..acc-off+n+1) += a[a-off..a-off+n) mod 2^(n+1) with c_in + PROVEN |0> by the caller. Mirror of HEAD's + cuccaro_add_fast_low_to_ext_borrowed_carries_no_cin at gate_suffix=0 + (the default env path). acc top bit (carry-out) lands at + acc[acc-off+n]. carries-reg[carries-offset..carries-offset+n-1] must + be |0> on entry; HMR uncompute returns them to |0> on exit. Consumes + n HMR classical bit IDs (bit-base..bit-base+n-1)." + (cond + ((= n 0) #t) + (else + ;; Step 0 forward (cin folded out — a[0] takes its place). + (gate-cx! c a-reg a-off acc-reg acc-off) + (gate-ccx! c a-reg a-off acc-reg acc-off carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg a-off) + ;; Forward sweep [1..n) — borrowed-carries path; clean-MAJ block + ;; (HEAD's `for i in borrowed..n`) is empty under gate_suffix=0. + (let loop-fwd ((i 1)) + (when (< i n) + (gate-cx! c a-reg (+ a-off i) acc-reg (+ acc-off i)) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-ccx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg (+ a-off i)) + (loop-fwd (+ i 1)))) + ;; Top sum lands at acc[n] — the low-to-ext extension. + (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off n)) + ;; Backward HMR uncompute sweep [1..n) reverse — borrowed pattern. + ;; HEAD's reverse clean-UMA block (`for i in (borrowed..n).rev`) is + ;; empty under gate_suffix=0. + (let loop-back ((i (- n 1))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) + a-reg (+ a-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) + (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i)) + (gate-pop-cond! c) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-cx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i)) + (loop-back (- i 1)))) + ;; Step 0 reverse — c_in folded out. cz_if on a[0] (the preceding + ;; cx(carries[0],a[0]) restored a[0] to c_in's frozen value). No + ;; trailing cx pair (see cuccaro-add-fast-borrowed-no-cin! docstring + ;; for the algebra rationale). + (gate-cx! c carries-reg carries-offset a-reg a-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c a-reg a-off acc-reg acc-off) + (gate-pop-cond! c)))) + +(define (cuccaro-sub-fast-low-to-ext-borrowed-no-cin! + c a-reg a-off acc-reg acc-off n + carries-reg carries-offset bit-base) + "acc[acc-off..acc-off+n+1) -= a[a-off..a-off+n) mod 2^(n+1) with + c_in PROVEN |0>. Mirror of HEAD's + cuccaro_sub_fast_low_to_ext_borrowed_carries_no_cin at gate_suffix=0. + See add variant docstring for the c_in folding algebra; sub retains + its trailing cx(a[0], acc[0]) per HEAD's sub-direction tail (the cz_if + pair drops out but the standalone XOR is independent of c_in)." + (cond + ((= n 0) #t) + (else + ;; Step 0 forward (cin folded out, sub direction has no seed CX). + (gate-ccx! c a-reg a-off acc-reg acc-off carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg a-off) + ;; Forward sweep [1..n) — sub direction; clean-INV-UMA block empty + ;; under gate_suffix=0. + (let loop-fwd ((i 1)) + (when (< i n) + (gate-cx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i)) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-ccx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg (+ a-off i)) + (loop-fwd (+ i 1)))) + ;; Top sum lands at acc[n]. + (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off n)) + ;; Backward HMR uncompute sweep [1..n) reverse — sub direction. + ;; Clean-INV-MAJ block empty under gate_suffix=0. + (let loop-back ((i (- n 1))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) + a-reg (+ a-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) + (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i)) + (gate-pop-cond! c) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-cx! c a-reg (+ a-off i) acc-reg (+ acc-off i)) + (loop-back (- i 1)))) + ;; Step 0 reverse — c_in folded out. + (gate-cx! c carries-reg carries-offset a-reg a-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c a-reg a-off acc-reg acc-off) + (gate-pop-cond! c) + ;; Trailing cx(a[0], acc[0]) — sub-direction algebra requires this + ;; independently of c_in folding (only the cz_if + reset triple + ;; collapses; standalone CX stays). + (gate-cx! c a-reg a-off acc-reg acc-off)))) + +;;; ── Per-block kernel for windowed wrappers ──────────────────────── +;;; +;;; cuccaro-add-fast-blk! / cuccaro-sub-fast-blk! — equal-width n add/sub +;;; with offset args plus top-bit overrides. Used by the windowed +;;; top-level for non-final blocks where the top bit of a is a fresh +;;; |0> ancilla (a-top-*) and the top bit of acc is a fresh cout +;;; ancilla (acc-top-*), each sitting in a separate register handle +;;; from the lo..hi-1 slice of the parent registers. +;;; +;;; Algebra mirrors `cuccaro_add_fast`(mod.rs:1042) but at every index +;;; i in [0,n), reads of `a[i]` and `acc[i]` resolve as: +;;; if i < n-1: (parent-reg, parent-off + i) +;;; if i = n-1: (top-reg, top-idx) +;;; +;;; carries-reg width MUST be >= n-1 starting at carries-offset. +;;; Consumes (n-1) HMR classical bit IDs. + +(define (cuccaro-add-fast-blk! c + a-reg a-off a-top-reg a-top-idx + acc-reg acc-off acc-top-reg acc-top-idx + cin-reg cin-idx + n + carries-reg carries-offset + bit-base) + "Equal-width Cuccaro fast-add at width n with split top-bit operands. + a[i= i 1) + (gate-cx! c carries-reg (+ carries-offset i) + a-reg (+ a-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) + (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i)) + (gate-pop-cond! c) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-cx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i)) + (loop-back (- i 1)))) + ;; Step 0 backward — uses cin + acc[0] + (gate-cx! c carries-reg carries-offset a-reg a-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg acc-off) + (gate-pop-cond! c) + (gate-cx! c a-reg a-off cin-reg cin-idx) + (gate-cx! c cin-reg cin-idx acc-reg acc-off)))) + +(define (cuccaro-sub-fast-blk! c + a-reg a-off a-top-reg a-top-idx + acc-reg acc-off acc-top-reg acc-top-idx + cin-reg cin-idx + n + carries-reg carries-offset + bit-base) + "Equal-width Cuccaro fast-sub at width n with split top-bit operands. + Top-bit override semantics identical to cuccaro-add-fast-blk!. + Consumes (n-1) HMR classical bit IDs." + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c a-top-reg a-top-idx acc-top-reg acc-top-idx) + (gate-cx! c cin-reg cin-idx acc-top-reg acc-top-idx)) + (else + (gate-cx! c cin-reg cin-idx acc-reg acc-off) + (gate-cx! c a-reg a-off cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg acc-off carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg a-off) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i)) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-ccx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg (+ a-off i)) + (loop-fwd (+ i 1)))) + ;; Final sub bit: two CXs into acc[n-1] = acc-top + ;; cx(a[n-1], acc[n-1]) cx(a[n-2], acc[n-1]) + (gate-cx! c a-top-reg a-top-idx acc-top-reg acc-top-idx) + (gate-cx! c a-reg (+ a-off (- n 2)) acc-top-reg acc-top-idx) + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) + a-reg (+ a-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) + (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i)) + (gate-pop-cond! c) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-cx! c a-reg (+ a-off i) acc-reg (+ acc-off i)) + (loop-back (- i 1)))) + (gate-cx! c carries-reg carries-offset a-reg a-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg acc-off) + (gate-pop-cond! c) + (gate-cx! c a-reg a-off cin-reg cin-idx) + (gate-cx! c a-reg a-off acc-reg acc-off)))) + +;;; ── Windowed Cuccaro fast-add / fast-sub ────────────────────────── +;;; +;;; Port of HEAD's `cuccaro_add_fast_windowed` (mod.rs:1995-2055) + +;;; `cuccaro_sub_fast_windowed` (mod.rs:2061-2117). +;;; +;;; Threads the inter-block carry/borrow through a 1-bit extension per +;;; block. ~(n/blocks) measured-carry ancillae live at once (vs n-1 for +;;; a single cuccaro-add-fast!). ~1 Toffoli/bit; the MBUC saving is +;;; PEAK QUBITS — total Toffoli increases by O(blocks) due to per-block +;;; boundary-clear cmp_lt calls. +;;; +;;; Caller pre-allocates a `name-base` symbol scope; the windowed wrapper +;;; alloc's per-block ancillae using `(string->symbol (string-append +;;; (symbol->string name-base) "-blk-K-cout"))` and frees them in reverse. +;;; +;;; bit-base reservation: the caller MUST reserve at LEAST the following +;;; HMR bit IDs starting at bit-base: +;;; - For each non-final block of width w_blk = hi-lo: +;;; the per-block call uses (w_blk + 1) - 1 = w_blk HMR bits +;;; (cuccaro-add-fast-blk! at n = w_blk + 1, consumes n-1 = w_blk) +;;; - For the final block at width w_last (no extension): +;;; cuccaro-add-fast! at n = w_last, consumes (n-1) = w_last-1 HMR +;;; - For each non-final block's boundary clear: +;;; cmp-lt-into-fast! at width p = hi, consumes p HMR bits +;;; +;;; Caller-side simplest upper bound: reserve 4n bit IDs starting at +;;; bit-base. We document tighter accounting per block below. + +(define (cuccaro-add-fast-windowed! c + a-reg acc-reg cin-reg cin-idx n + blocks + name-base bit-base) + "acc := (acc + a + cin) mod 2^n via blocks-wise dispatch. + blocks >= 1; clamped to [1, n]. blocks=1 falls back to + cuccaro-add-fast! (uses a freshly-alloc'd carries register + named (name-base)-carries-direct). + See module header for bit-base reservation rules." + (cond + ((= n 0) #t) + (else + (let* ((blocks (cond ((< blocks 1) 1) + ((> blocks n) n) + (else blocks)))) + (cond + ((= blocks 1) + ;; Direct fallback: alloc carries (n-1) + delegate + (let ((carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-direct")))) + (alloc! c carries-name (- n 1)) + (cuccaro-add-fast! c a-reg acc-reg cin-reg cin-idx n + carries-name bit-base) + (free! c carries-name))) + (else + ;; Walk blocks, threading carry. Track (cout-name, p) pairs. + (let loop ((blk 0) + (lo 0) + (carry-reg cin-reg) + (carry-idx cin-idx) + (bit-cur bit-base) + (couts '())) + (cond + ((>= blk blocks) + ;; Boundary clear pass over couts (reverse order). + (windowed-clear-couts! c a-reg acc-reg + couts + name-base bit-cur + 'add) + #t) + (else + (let* ((hi (quotient (* (+ blk 1) n) blocks))) + (cond + ((<= hi lo) + (loop (+ blk 1) lo carry-reg carry-idx bit-cur couts)) + ((or (= blk (- blocks 1)) (= hi n)) + ;; LAST block — non-extended cuccaro_add_fast at + ;; width (n - lo). Direct call into existing + ;; cuccaro-add-fast! which expects a-reg/acc-reg + ;; from index 0; we need an offset-aware variant. + ;; Use cuccaro-add-fast-blk! with a-top-* + acc-top-* + ;; pointing back into the parent at index (n-1). + (let* ((w (- n lo)) + (carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-final")))) + (cond + ((= w 0) #t) + ((= w 1) + ;; Trivial 1-bit add at slot lo + (gate-cx! c carry-reg carry-idx acc-reg lo) + (gate-cx! c a-reg lo acc-reg lo)) + (else + (alloc! c carries-name (- w 1)) + (cuccaro-add-fast-blk! + c + a-reg lo + a-reg (+ lo (- w 1)) ; a-top = parent[n-1] + acc-reg lo + acc-reg (+ lo (- w 1)) ; acc-top = parent[n-1] + carry-reg carry-idx + w + carries-name 0 + bit-cur) + (free! c carries-name))) + ;; final block — boundary clear over outstanding couts + (windowed-clear-couts! c a-reg acc-reg + couts + name-base + (+ bit-cur (max 0 (- w 1))) + 'add))) + (else + ;; NON-final block — width w_blk = hi - lo, extended + ;; with fresh zero (above a slice) + cout (above acc + ;; slice). cuccaro-add-fast-blk! at n = w_blk + 1. + (let* ((w-blk (- hi lo)) + (n-ext (+ w-blk 1)) + (cout-name + (string->symbol + (string-append (symbol->string name-base) + "-cout-" + (number->string blk)))) + (zero-name + (string->symbol + (string-append (symbol->string name-base) + "-zero-" + (number->string blk)))) + (carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-" + (number->string blk))))) + (alloc! c cout-name 1) + (alloc! c zero-name 1) + (alloc! c carries-name (- n-ext 1)) + (cuccaro-add-fast-blk! + c + a-reg lo + zero-name 0 ; a-top = fresh |0> ancilla + acc-reg lo + cout-name 0 ; acc-top = cout ancilla + carry-reg carry-idx + n-ext + carries-name 0 + bit-cur) + (free! c carries-name) + (free! c zero-name) + (loop (+ blk 1) + hi + cout-name 0 + (+ bit-cur (- n-ext 1)) + (cons (list cout-name hi) couts)))))))))))))) + #t) + +(define (cuccaro-sub-fast-windowed! c + a-reg acc-reg cin-reg cin-idx n + blocks + name-base bit-base) + "acc := (acc - a - cin) mod 2^n via blocks-wise dispatch. + Mirror of cuccaro-add-fast-windowed! using sub kernels. + blocks=1 falls back to cuccaro-sub-fast!." + (cond + ((= n 0) #t) + (else + (let ((blocks (cond ((< blocks 1) 1) + ((> blocks n) n) + (else blocks)))) + (cond + ((= blocks 1) + (let ((carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-direct")))) + (alloc! c carries-name (- n 1)) + (cuccaro-sub-fast! c a-reg acc-reg cin-reg cin-idx n + carries-name bit-base) + (free! c carries-name))) + (else + (let loop ((blk 0) + (lo 0) + (borrow-reg cin-reg) + (borrow-idx cin-idx) + (bit-cur bit-base) + (bouts '())) + (cond + ((>= blk blocks) + (windowed-clear-couts! c a-reg acc-reg + bouts + name-base bit-cur + 'sub) + #t) + (else + (let* ((hi (quotient (* (+ blk 1) n) blocks))) + (cond + ((<= hi lo) + (loop (+ blk 1) lo borrow-reg borrow-idx bit-cur bouts)) + ((or (= blk (- blocks 1)) (= hi n)) + (let* ((w (- n lo)) + (carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-final")))) + (cond + ((= w 0) #t) + ((= w 1) + (gate-cx! c a-reg lo acc-reg lo) + (gate-cx! c borrow-reg borrow-idx acc-reg lo)) + (else + (alloc! c carries-name (- w 1)) + (cuccaro-sub-fast-blk! + c + a-reg lo + a-reg (+ lo (- w 1)) + acc-reg lo + acc-reg (+ lo (- w 1)) + borrow-reg borrow-idx + w + carries-name 0 + bit-cur) + (free! c carries-name))) + (windowed-clear-couts! c a-reg acc-reg + bouts + name-base + (+ bit-cur (max 0 (- w 1))) + 'sub))) + (else + (let* ((w-blk (- hi lo)) + (n-ext (+ w-blk 1)) + (bout-name + (string->symbol + (string-append (symbol->string name-base) + "-bout-" + (number->string blk)))) + (zero-name + (string->symbol + (string-append (symbol->string name-base) + "-zero-" + (number->string blk)))) + (carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-" + (number->string blk))))) + (alloc! c bout-name 1) + (alloc! c zero-name 1) + (alloc! c carries-name (- n-ext 1)) + (cuccaro-sub-fast-blk! + c + a-reg lo + zero-name 0 + acc-reg lo + bout-name 0 + borrow-reg borrow-idx + n-ext + carries-name 0 + bit-cur) + (free! c carries-name) + (free! c zero-name) + (loop (+ blk 1) + hi + bout-name 0 + (+ bit-cur (- n-ext 1)) + (cons (list bout-name hi) bouts)))))))))))))) + #t) + +;;; Internal: boundary-carry / borrow clearer for windowed-add/sub. +;;; For add: c_j := (acc[0..p] < a[0..p]) — cmp-lt-into-fast!(acc, a) +;;; For sub: b_j := (a[0..p] < acc[0..p]) after X-flipping a[0..p] +;;; i.e. (~a < acc) — cmp-lt-into-fast!(a, acc) with a inverted, +;;; then a restored. +;;; Frees each cout/bout in reverse order. + +(define (windowed-clear-couts! c a-reg acc-reg couts + name-base bit-start direction) + "Clear boundary carries (direction='add) or borrows (direction='sub). + couts is a list of (name p) pairs in REVERSE processing order + (we just walk left-to-right since it's already reversed by cons). + bit-start = bit-base offset for the cmp HMRs." + (let loop ((items couts) (bit-cur bit-start)) + (cond + ((null? items) #t) + (else + (let* ((item (car items)) + (cname (car item)) + (p (cadr item)) + (carries-name + (string->symbol + (string-append (symbol->string name-base) + "-cmp-carries-" + (symbol->string cname)))) + (cin-name + (string->symbol + (string-append (symbol->string name-base) + "-cmp-cin-" + (symbol->string cname))))) + (alloc! c carries-name p) + (alloc! c cin-name 1) + (cond + ((eq? direction 'add) + ;; cmp-lt-into-fast!(acc[0..p], a[0..p], cname) + (cmp-lt-into-fast! c acc-reg a-reg p + cname 0 + cin-name 0 + carries-name 0 bit-cur)) + (else + ;; sub: X-flip a[0..p], cmp-lt-into-fast!(a, acc), un-X-flip + (let loopx ((i 0)) + (when (< i p) (gate-x! c a-reg i) (loopx (+ i 1)))) + (cmp-lt-into-fast! c a-reg acc-reg p + cname 0 + cin-name 0 + carries-name 0 bit-cur) + (let loopx ((i 0)) + (when (< i p) (gate-x! c a-reg i) (loopx (+ i 1)))))) + (free! c cin-name) + (free! c carries-name) + (free! c cname) + (loop (cdr items) (+ bit-cur p))))))) + +;;; ── Windowed Cuccaro fast-add / fast-sub — low-to-ext family ───── +;;; +;;; Port of HEAD's `cuccaro_add_fast_windowed_low_to_ext` (mod.rs:2119) +;;; + `cuccaro_sub_fast_windowed_low_to_ext` (mod.rs:2169). +;;; +;;; Same threading shape as the non-ext windowed; final block calls +;;; cuccaro-add-fast-low-to-ext! (offset-aware) instead of +;;; cuccaro-add-fast-blk!. acc-reg is (n+1)-wide, a-reg is n-wide. +;;; The block partition is over ext_n = n+1 (not n) — last block's +;;; a-slice may be shorter than its acc-slice. +;;; +;;; bit-base reservation identical to non-ext windowed plus 1 extra +;;; HMR bit per non-final block (kernel consumes n-ext-1 = w_blk bits, +;;; same as non-ext) — the final block consumes n_final HMR bits (one +;;; more than non-ext since _low_to_ext loops over n iters not n-1). + +(define (cuccaro-add-fast-windowed-low-to-ext! c + a-reg acc-reg + cin-reg cin-idx + n + blocks + name-base bit-base) + "acc-ext := (acc-ext + a + cin) mod 2^(n+1) via blocks-wise dispatch. + a-reg width n; acc-reg width n+1. blocks >= 1; clamped to [1, n+1]. + blocks=1 falls back to cuccaro-add-fast-low-to-ext! (alloc carries)." + (let* ((ext-n (+ n 1))) + (cond + ((= ext-n 0) #t) + (else + (let ((blocks (cond ((< blocks 1) 1) + ((> blocks ext-n) ext-n) + (else blocks)))) + (cond + ((= blocks 1) + (let ((carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-direct")))) + (alloc! c carries-name n) + (cuccaro-add-fast-low-to-ext! c + a-reg 0 + acc-reg 0 + cin-reg cin-idx + n + carries-name 0 + bit-base) + (free! c carries-name))) + (else + (let loop ((blk 0) + (lo 0) + (carry-reg cin-reg) + (carry-idx cin-idx) + (bit-cur bit-base) + (couts '())) + (cond + ((>= blk blocks) + (windowed-clear-couts-low-to-ext! c a-reg acc-reg + couts + name-base bit-cur + 'add) + #t) + (else + (let* ((hi (quotient (* (+ blk 1) ext-n) blocks))) + (cond + ((<= hi lo) + (loop (+ blk 1) lo carry-reg carry-idx bit-cur couts)) + ((or (= blk (- blocks 1)) (= hi ext-n)) + ;; LAST block — _low_to_ext at source-width (n - lo). + ;; (acc slice is hi - lo, which equals (n+1) - lo; + ;; matches _low_to_ext convention.) + (let* ((w-src (- n lo)) + (carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-final")))) + (cond + ((= w-src 0) + ;; degenerate: only one acc bit beyond lo + (gate-cx! c carry-reg carry-idx acc-reg lo)) + (else + (alloc! c carries-name w-src) + (cuccaro-add-fast-low-to-ext! + c + a-reg lo + acc-reg lo + carry-reg carry-idx + w-src + carries-name 0 + bit-cur) + (free! c carries-name))) + (windowed-clear-couts-low-to-ext! + c a-reg acc-reg + couts + name-base + (+ bit-cur w-src) + 'add))) + (else + ;; NON-final block — width w_blk = hi - lo. Uses + ;; cuccaro-add-fast-blk! at n = w_blk + 1 with + ;; zero ancilla above a-slice + cout above + ;; acc-slice. (Same shape as non-ext windowed.) + (let* ((w-blk (- hi lo)) + (n-ext-k (+ w-blk 1)) + (cout-name + (string->symbol + (string-append (symbol->string name-base) + "-cout-" + (number->string blk)))) + (zero-name + (string->symbol + (string-append (symbol->string name-base) + "-zero-" + (number->string blk)))) + (carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-" + (number->string blk))))) + (alloc! c cout-name 1) + (alloc! c zero-name 1) + (alloc! c carries-name (- n-ext-k 1)) + (cuccaro-add-fast-blk! + c + a-reg lo + zero-name 0 + acc-reg lo + cout-name 0 + carry-reg carry-idx + n-ext-k + carries-name 0 + bit-cur) + (free! c carries-name) + (free! c zero-name) + (loop (+ blk 1) + hi + cout-name 0 + (+ bit-cur (- n-ext-k 1)) + (cons (list cout-name hi) couts))))))))))))))) + #t) + +(define (cuccaro-sub-fast-windowed-low-to-ext! c + a-reg acc-reg + cin-reg cin-idx + n + blocks + name-base bit-base) + "acc-ext := (acc-ext - a - cin) mod 2^(n+1) via blocks-wise dispatch. + Mirror of cuccaro-add-fast-windowed-low-to-ext!." + (let* ((ext-n (+ n 1))) + (cond + ((= ext-n 0) #t) + (else + (let ((blocks (cond ((< blocks 1) 1) + ((> blocks ext-n) ext-n) + (else blocks)))) + (cond + ((= blocks 1) + (let ((carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-direct")))) + (alloc! c carries-name n) + (cuccaro-sub-fast-low-to-ext! c + a-reg 0 + acc-reg 0 + cin-reg cin-idx + n + carries-name 0 + bit-base) + (free! c carries-name))) + (else + (let loop ((blk 0) + (lo 0) + (borrow-reg cin-reg) + (borrow-idx cin-idx) + (bit-cur bit-base) + (bouts '())) + (cond + ((>= blk blocks) + (windowed-clear-couts-low-to-ext! c a-reg acc-reg + bouts + name-base bit-cur + 'sub) + #t) + (else + (let* ((hi (quotient (* (+ blk 1) ext-n) blocks))) + (cond + ((<= hi lo) + (loop (+ blk 1) lo borrow-reg borrow-idx bit-cur bouts)) + ((or (= blk (- blocks 1)) (= hi ext-n)) + (let* ((w-src (- n lo)) + (carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-final")))) + (cond + ((= w-src 0) + (gate-cx! c borrow-reg borrow-idx acc-reg lo)) + (else + (alloc! c carries-name w-src) + (cuccaro-sub-fast-low-to-ext! + c + a-reg lo + acc-reg lo + borrow-reg borrow-idx + w-src + carries-name 0 + bit-cur) + (free! c carries-name))) + (windowed-clear-couts-low-to-ext! + c a-reg acc-reg + bouts + name-base + (+ bit-cur w-src) + 'sub))) + (else + (let* ((w-blk (- hi lo)) + (n-ext-k (+ w-blk 1)) + (bout-name + (string->symbol + (string-append (symbol->string name-base) + "-bout-" + (number->string blk)))) + (zero-name + (string->symbol + (string-append (symbol->string name-base) + "-zero-" + (number->string blk)))) + (carries-name + (string->symbol + (string-append (symbol->string name-base) + "-carries-" + (number->string blk))))) + (alloc! c bout-name 1) + (alloc! c zero-name 1) + (alloc! c carries-name (- n-ext-k 1)) + (cuccaro-sub-fast-blk! + c + a-reg lo + zero-name 0 + acc-reg lo + bout-name 0 + borrow-reg borrow-idx + n-ext-k + carries-name 0 + bit-cur) + (free! c carries-name) + (free! c zero-name) + (loop (+ blk 1) + hi + bout-name 0 + (+ bit-cur (- n-ext-k 1)) + (cons (list bout-name hi) bouts))))))))))))))) + #t) + +;;; Internal: boundary-carry / borrow clearer for _windowed_low_to_ext. +;;; For add: c_j := (acc_ext[0..p] < a[0..p]) +;;; — but only the first n bits of a exist; if p > n the cmp +;;; must treat a's high bits as zero. We pad by reusing the +;;; zero ancillae are gone; safest path: alloc an a-pad register +;;; of width (p - n) at |0> and copy a + pad into a virtual +;;; width-p slice. To keep the wire simple, we cap p at n: when +;;; a non-final block's hi > n, p exceeds n. Since HEAD's +;;; source loops over `&acc_ext[..p]` and `&a[..p]`, & Rust's +;;; `&a[..p]` would PANIC if p > n.len() — so HEAD's partition +;;; must guarantee non-final boundaries hi ≤ n. The block +;;; partition `hi = ((blk+1) * ext_n) / blocks` allows hi to +;;; land on n+1 ONLY for the last block (caught by the +;;; `hi == ext_n` short-circuit), so non-final hi ≤ n always +;;; holds when blocks ≥ 2. + +(define (windowed-clear-couts-low-to-ext! c a-reg acc-reg couts + name-base bit-start direction) + "Like windowed-clear-couts! but for _low_to_ext family. The cmp + ranges only over [0, p) where p ≤ n (caller's source-register width) + — HEAD's partition ensures non-final hi ≤ n." + (let loop ((items couts) (bit-cur bit-start)) + (cond + ((null? items) #t) + (else + (let* ((item (car items)) + (cname (car item)) + (p (cadr item)) + (carries-name + (string->symbol + (string-append (symbol->string name-base) + "-cmp-carries-" + (symbol->string cname)))) + (cin-name + (string->symbol + (string-append (symbol->string name-base) + "-cmp-cin-" + (symbol->string cname))))) + (alloc! c carries-name p) + (alloc! c cin-name 1) + (cond + ((eq? direction 'add) + (cmp-lt-into-fast! c acc-reg a-reg p + cname 0 + cin-name 0 + carries-name 0 bit-cur)) + (else + (let loopx ((i 0)) + (when (< i p) (gate-x! c a-reg i) (loopx (+ i 1)))) + (cmp-lt-into-fast! c a-reg acc-reg p + cname 0 + cin-name 0 + carries-name 0 bit-cur) + (let loopx ((i 0)) + (when (< i p) (gate-x! c a-reg i) (loopx (+ i 1)))))) + (free! c cin-name) + (free! c carries-name) + (free! c cname) + (loop (cdr items) (+ bit-cur p))))))) + +;;; *windowed-block-count* — global flag controlling block count. +;;; Default 1 = behave like the non-windowed fast variants. Set to k>1 +;;; via lever-variants.lsp once the wiring sweep ports +;;; ctrl-cuccaro-*-hosted! to dispatch into the windowed entry points. + +(define *windowed-block-count* 1) + +;;; ── sweep-058 apply-phase-aware windowed-add wrapper ────────────── +;;; +;;; HEAD reference: `ecdsafail-challenge/src/point_add/arith/adder.rs:655` +;;; `cuccaro_add_fast_windowed_low_to_ext` — fixed-window block +;;; decomposition that processes inter-block carries via speculative +;;; carry-skip + boundary `cmp_lt_into_fast_with_cin` cleanup. HEAD's +;;; Gidney-2025 vented apply-phase architecture layered on top (per +;;; venting.rs:147-309 + APPLY-PHASE-ROADMAP item 4) defers boundary +;;; phase-corrections via vent-keys → broadcast-CZ flush instead of +;;; inline push-cond / cz / pop-cond per boundary. Predicted score +;;; reduction: -8 % to -12 % at production width once a hot-loop +;;; callsite (mod-mul-solinas hot path) dispatches into this wrapper. +;;; +;;; sweep-058 lands wrapper + flag. Callsite wiring stays gated on +;;; later sweeps (mod-arith.lsp + mod-inv-by-dialog-gcd-host.lsp +;;; owned by separate branches per sweep-054 fence rule). Cell with +;;; flag #t must be byte-identical to champion at production width +;;; until a dispatch site lands — matches sweep-054's substrate +;;; integration discipline (no-op until wired). +;;; +;;; Wrapper steps: +;;; +;;; 1. Open an apply-phase scope via `begin-apply-phase!` (no-op +;;; when *apply-phase-architecture* off; sentinel scope-id 0 +;;; otherwise). +;;; 2. Delegate to existing `cuccaro-add-fast-windowed-low-to-ext!` +;;; primitive. Boundary `cmp-lt-into-fast!` push-cond/cz/pop-cond +;;; triples stay emitted inline; deferring them into vent_keys +;;; lives in a follow-up retrofit that needs the windowed +;;; primitive itself to consume `defer-phase!`. Sweep-058 ships +;;; a scope envelope so a follow-up sweep can route the boundary +;;; phase corrections through `defer-phase!` without changing +;;; this wrapper's signature. +;;; 3. Flush pending phase tasks via `flush-phase!` with empty +;;; `targets` — single-Z-per-pending under the current substrate. +;;; Empty `pending` list when flag is off or when the inner +;;; primitive has not been retrofitted to defer; the flush is +;;; a no-op in that case. +;;; 4. Close the scope via `end-apply-phase!`, which asserts the +;;; pending list is clear (catches missing flush calls). +;;; +;;; Defensive: substrate APIs guarded by sentinel `sid = 0` so flag +;;; flipped off bypasses every substrate call. apply-phase.lsp loads +;;; before adder.lsp via emit-stream.lsp's load chain, so the +;;; substrate APIs are present at every production callsite. + +(define *cuccaro-add-windowed* #f) + +(define (cuccaro-add-fast-windowed-low-to-ext-applyphase! c + a-reg acc-reg + cin-reg cin-idx + n + blocks + name-base bit-base) + "Apply-phase-wrapped windowed cuccaro-add fast low-to-ext. + + Algebra identical to `cuccaro-add-fast-windowed-low-to-ext!`. Opens + an apply-phase scope around the windowed dispatch so a future + retrofit can route per-boundary phase corrections into vent_keys + + broadcast-CZ flush. + + When `*apply-phase-architecture*` is #f the substrate APIs are + no-ops; this wrapper degenerates to a direct call into the + non-wrapped primitive. Byte-identical to a plain + `cuccaro-add-fast-windowed-low-to-ext!` call until a downstream + sweep adds `defer-phase!` calls into the per-block boundary path." + (let ((sid + (cond + ((and *cuccaro-add-windowed* + *apply-phase-architecture*) + (begin-apply-phase! c)) + (else 0)))) + (cuccaro-add-fast-windowed-low-to-ext! c + a-reg acc-reg + cin-reg cin-idx + n + blocks + name-base bit-base) + (cond + ((not (= sid 0)) + (flush-phase! c sid (quote ())) + (end-apply-phase! c sid)) + (else #t)))) + +(define (cuccaro-sub-fast-windowed-low-to-ext-applyphase! c + a-reg acc-reg + cin-reg cin-idx + n + blocks + name-base bit-base) + "Mirror of cuccaro-add-fast-windowed-low-to-ext-applyphase! for sub." + (let ((sid + (cond + ((and *cuccaro-add-windowed* + *apply-phase-architecture*) + (begin-apply-phase! c)) + (else 0)))) + (cuccaro-sub-fast-windowed-low-to-ext! c + a-reg acc-reg + cin-reg cin-idx + n + blocks + name-base bit-base) + (cond + ((not (= sid 0)) + (flush-phase! c sid (quote ())) + (end-apply-phase! c sid)) + (else #t)))) + +;;; ── sweep-windowed-wiring apply-phase wrappers (non-low-to-ext) ──── +;;; +;;; HEAD reference: `cuccaro_add_fast_windowed` (mod.rs:1995-2055) — +;;; same shape as `cuccaro_add_fast_windowed_low_to_ext` (the wrapper +;;; above) but without the acc[n] extension bit. Used by mod-add! + +;;; mod-add-inplace-pseudo-mersenne! step (1) at width n+1 where +;;; both a-reg and acc-reg already carry an extension slot at index n. +;;; +;;; Apply-phase scope semantics IDENTICAL to the low-to-ext sibling. +;;; A future defer-phase retrofit on `windowed-clear-couts!` boundary +;;; phase corrections would route the cmp-lt-into-fast! push-cond / +;;; cz_if / pop-cond triples through `defer-phase!` so a single +;;; `flush-phase!` at scope-end collapses the per-boundary corrections +;;; into one broadcast-CZ — sweep-075's unblock for the windowed wiring +;;; to actually beat the non-windowed baseline. THAT retrofit is NOT +;;; included in sweep-windowed-wiring; this sweep ships the wrapper + +;;; the four hot-path callsites, then measures the un-deferred regime +;;; so the next sweep has a quantified baseline for the defer-phase work. + +(define (cuccaro-add-fast-windowed-applyphase! c + a-reg acc-reg + cin-reg cin-idx + n + blocks + name-base bit-base) + "Apply-phase-wrapped windowed cuccaro-add fast (NON-extended). + Algebra identical to `cuccaro-add-fast-windowed!`. Opens an + apply-phase scope around the windowed dispatch so a follow-up + sweep can route per-boundary phase corrections via vent_keys + + broadcast-CZ flush. When `*apply-phase-architecture*` is #f the + substrate APIs are no-ops; degenerates to plain + `cuccaro-add-fast-windowed!`." + (let ((sid + (cond + ((and *cuccaro-add-windowed* + *apply-phase-architecture*) + (begin-apply-phase! c)) + (else 0)))) + (cuccaro-add-fast-windowed! c + a-reg acc-reg + cin-reg cin-idx + n + blocks + name-base bit-base) + (cond + ((not (= sid 0)) + (flush-phase! c sid (quote ())) + (end-apply-phase! c sid)) + (else #t)))) + +(define (cuccaro-sub-fast-windowed-applyphase! c + a-reg acc-reg + cin-reg cin-idx + n + blocks + name-base bit-base) + "Mirror of cuccaro-add-fast-windowed-applyphase! for sub." + (let ((sid + (cond + ((and *cuccaro-add-windowed* + *apply-phase-architecture*) + (begin-apply-phase! c)) + (else 0)))) + (cuccaro-sub-fast-windowed! c + a-reg acc-reg + cin-reg cin-idx + n + blocks + name-base bit-base) + (cond + ((not (= sid 0)) + (flush-phase! c sid (quote ())) + (end-apply-phase! c sid)) + (else #t)))) + +;;; *cuccaro-maj2* — HEAD's fold_maj2 / perpos_maj2 lever. +;;; +;;; Algebra (per HEAD const_arith.rs:507-525): +;;; 3-CCX maj: target ^= maj(acc, k, c) +;;; ccx(acc, ci, target) +;;; ccx(ctrl, acc, target) +;;; ccx(ctrl, ci, target) +;;; 2-CCX+2-CX equivalent (saves 1 CCX per maj position): +;;; ccx(acc, ci, target) +;;; cx(acc, ci) ; transient +;;; ccx(ctrl, ci, target) +;;; cx(acc, ci) ; restore +;;; +;;; SUBSTRATE GAP — this flag is currently a no-op in our emit graph. +;;; +;;; HEAD applies maj2 ONLY to the const-coefficient direct-carry-chain +;;; adders fold_maj2 → cadd_nbit_const_direct_trunc_fast + +;;; csub_nbit_const_direct_trunc_fast; perpos_maj2 → +;;; cadd_per_position_controls_trunc + csub_per_position_controls_trunc +;;; (HEAD const_arith.rs:487-735). These four primitives generate one +;;; explicit carry per acc bit via a 3-CCX target-fanout maj(acc,ci,ctrl) +;;; where the third input (ctrl) is the SAME QUBIT every position — that +;;; is what enables the (cx acc,ci)(ccx ctrl,ci,target)(cx acc,ci) +;;; substitution to land. +;;; +;;; Lumbda has no const-direct-carry-chain adder. Our add-const! / +;;; csub-const! (mod-arith.lsp:51-68) implement the const add via +;;; classical-X load → cuccaro-add! (1-CCX-per-bit Cuccaro in-place +;;; MAJ form) → unload. Cuccaro's maj at every bit i reads two +;;; DIFFERENT operand qubits (a[i-1], acc[i]) writing to a[i] — no +;;; 3-CCX target-fanout cluster exists. Verified by gate-scan +;;; (sweep-047 search): no 3 consecutive gate-ccx! calls in any +;;; lumbda .lsp share a common target. +;;; +;;; To activate maj2 we must FIRST port HEAD's +;;; cadd_nbit_const_direct_trunc_fast (mod.rs near const_arith.rs:487) +;;; as a new lumbda primitive, then wire mod-arith.lsp's add-const! to +;;; dispatch into it under a separate substrate flag. The maj2 flag +;;; below stays defined so a future sweep can land the dispatch + flip +;;; the lever without churning the registry. +;;; +;;; Default #f. With no maj2 dispatch sites in the current substrate, +;;; setting #t is a no-op — production score unchanged. Probe-width +;;; verification in sweep-047 confirms the flag is byte-neutral on the +;;; current champion stack (no algorithmic disturbance from defining +;;; the variable itself). + +(define *cuccaro-maj2* #f) + +;;; ── sweep-056 apply-phase-aware vented variants ────────────────── +;;; +;;; Each vented variant: +;;; 1. Opens an apply-phase scope via (begin-apply-phase! c) so the +;;; substrate's end-of-emit assertion catches any unclosed scope. +;;; 2. Sources HMR classical bit IDs from (apply-phase-bit-next) + +;;; (apply-phase-set-bit-next!) instead of the caller-supplied +;;; bit-base. Bit IDs originate at 1,000,000 (per +;;; *apply-phase-bit-base*) so they cannot collide with the +;;; caller's local bit-base range (dgcd-host stays well under 1e4 +;;; at n+1=257). +;;; 3. Emits the identical gate sequence to the legacy fast variant — +;;; forward MAJ-like sweep + HMR backward uncompute. Operand-mutation +;;; analysis shows the backward CZ_if cannot be deferred to a flush +;;; because (a[i-1], acc[i]) get rewritten by subsequent iters. +;;; 4. Closes the scope via (end-apply-phase! c scope) — pending list +;;; must be empty since we never call defer-phase! (we manage HMRs +;;; manually to keep the per-iter inline cz_if pattern intact). +;;; +;;; Wire-level diff vs legacy: bit IDs originate at >=1e6 instead of +;;; caller's bit-base. Gate sequence identical. ops_hash WILL differ +;;; (bit IDs are part of QECCOPS1 wire); algorithmic semantics unchanged. +;;; Probe widths confirm correctness via byte-identity vs flag #f. + +(define (cuccaro-vented-alloc-bits! n) + "Reserve n consecutive vent-key BitIds from the apply-phase substrate. + Returns the base BitId. Caller uses base..base+n-1. Advances the + substrate's bit-next allocator. Assumes substrate state is live — + call only inside an open apply-phase scope." + (apply-phase-ensure!) + (let ((base (apply-phase-bit-next))) + (apply-phase-set-bit-next! (+ base n)) + base)) + +(define (cuccaro-add-fast-vented! c a-reg acc-reg cin-reg cin-idx n + carries-name bit-base-unused) + "Vented variant of cuccaro-add-fast!. Algorithmically identical to + the legacy fast path; vent-key BitIds sourced from apply-phase + substrate allocator. bit-base-unused parameter retained for ABI + parity; ignored by the body." + (begin + (apply-phase-ensure!) + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c cin-reg cin-idx acc-reg 0) + (gate-cx! c a-reg 0 acc-reg 0) + #t) + (else + (let ((bit-base (cuccaro-vented-alloc-bits! n))) + (gate-cx! c a-reg 0 acc-reg 0) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-name 0) + (gate-cx! c carries-name 0 a-reg 0) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg i acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i carries-name i) + (gate-cx! c carries-name i a-reg i) + (loop-fwd (+ i 1)))) + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-name i a-reg i) + (gate-hmr! c carries-name i (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg (- i 1) acc-reg i) + (loop-back (- i 1)))) + (gate-cx! c carries-name 0 a-reg 0) + (gate-hmr! c carries-name 0 bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg 0) + (gate-pop-cond! c) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-cx! c cin-reg cin-idx acc-reg 0)))))) + +(define (cuccaro-sub-fast-vented! c a-reg acc-reg cin-reg cin-idx n + carries-name bit-base-unused) + "Vented variant of cuccaro-sub-fast!. ABI mirror of the add variant." + (begin + (apply-phase-ensure!) + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c a-reg 0 acc-reg 0) + (gate-cx! c cin-reg cin-idx acc-reg 0) + #t) + (else + (let ((bit-base (cuccaro-vented-alloc-bits! n))) + (gate-cx! c cin-reg cin-idx acc-reg 0) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-name 0) + (gate-cx! c carries-name 0 a-reg 0) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg (- i 1) acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i carries-name i) + (gate-cx! c carries-name i a-reg i) + (loop-fwd (+ i 1)))) + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-name i a-reg i) + (gate-hmr! c carries-name i (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg i acc-reg i) + (loop-back (- i 1)))) + (gate-cx! c carries-name 0 a-reg 0) + (gate-hmr! c carries-name 0 bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg 0) + (gate-pop-cond! c) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-cx! c a-reg 0 acc-reg 0)))))) + +(define (cuccaro-add-fast-borrowed-vented! c a-reg acc-reg cin-reg cin-idx n + carries-reg carries-offset + bit-base-unused) + "Vented variant of cuccaro-add-fast-borrowed!." + (begin + (apply-phase-ensure!) + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c cin-reg cin-idx acc-reg 0) + (gate-cx! c a-reg 0 acc-reg 0) + #t) + (else + (let ((bit-base (cuccaro-vented-alloc-bits! n))) + (gate-cx! c a-reg 0 acc-reg 0) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg 0) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg i acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (loop-fwd (+ i 1)))) + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg (- i 1) acc-reg i) + (loop-back (- i 1)))) + (gate-cx! c carries-reg carries-offset a-reg 0) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg 0) + (gate-pop-cond! c) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-cx! c cin-reg cin-idx acc-reg 0)))))) + +(define (cuccaro-sub-fast-borrowed-vented! c a-reg acc-reg cin-reg cin-idx n + carries-reg carries-offset + bit-base-unused) + "Vented variant of cuccaro-sub-fast-borrowed!. Mirror of the add." + (begin + (apply-phase-ensure!) + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c a-reg 0 acc-reg 0) + (gate-cx! c cin-reg cin-idx acc-reg 0) + #t) + (else + (let ((bit-base (cuccaro-vented-alloc-bits! n))) + (gate-cx! c cin-reg cin-idx acc-reg 0) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg 0 carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg 0) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg (- i 1) acc-reg i) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-ccx! c a-reg (- i 1) acc-reg i carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (loop-fwd (+ i 1)))) + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) a-reg i) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (- i 1) acc-reg i) + (gate-pop-cond! c) + (gate-cx! c a-reg i a-reg (- i 1)) + (gate-cx! c a-reg i acc-reg i) + (loop-back (- i 1)))) + (gate-cx! c carries-reg carries-offset a-reg 0) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg 0) + (gate-pop-cond! c) + (gate-cx! c a-reg 0 cin-reg cin-idx) + (gate-cx! c a-reg 0 acc-reg 0)))))) + +;;; ── cuccaro_add/sub_ctrl_vented — body-side VENTED variants ─────── +;;; +;;; Port of HEAD origin/main (2026-06-10 18:18 UTC update): +;;; arith/adder.rs:1303 cuccaro_add_ctrl_vented +;;; arith/adder.rs:1334 cuccaro_sub_ctrl_vented +;;; +;;; Controlled add/sub where the carry chain is fully VENTED onto a +;;; BORROWED vent_pool of n-1 clean |0> qubits (no fresh alloc; peak +;;; does not grow). Measured uncompute via HMR + cz_if returns the +;;; vent_pool to |0> on exit, mirroring the cas-fast comparator pattern +;;; on the body-add side. +;;; +;;; HEAD docstring attribution: "Port of trailmix +;;; controlled_hybrid_add_refs (full vents)". The "hybrid" piece is +;;; the X-sandwich sub form (sub = ~(~add)) — keeps a SINGLE forward +;;; primitive and derives sub via two unconditional X-passes around +;;; the add. At ctrl=0 the inner add is identity, so the X;X pair +;;; cancels and the whole call is a no-op (per HEAD comment line 1331). +;;; +;;; Wiring: dialog/mod.rs:716 + 918 (the only two HEAD callsites, +;;; both inside DGCD STEP 4 body sub/add). Lumbda's equivalent +;;; callsites live in ctrl-cuccaro-{sub,add}-hosted! at STEP 4 — +;;; tmp is idle there after STEP 2 comparator's borrow closes, so +;;; vent_pool can fill from tmp without growing peak qubits. + +(define (cuccaro-add-ctrl-vented! c + ctrl-reg ctrl-idx + addend-reg acc-reg n + vent-pool-reg vent-pool-offset + bit-base) + "acc XOR= ctrl & addend (mod 2^n). vent_pool[0..n-2] borrowed |0>; + restored to |0> via HMR uncompute. Consumes n-1 HMR classical bit + IDs at bit-base..bit-base+n-2. n=1 trivializes to ccx(ctrl, addend, acc)." + (cond + ((= n 0) #t) + ((= n 1) + (gate-ccx! c ctrl-reg ctrl-idx addend-reg 0 acc-reg 0)) + (else + ;; line A: acc[i] XOR= addend[i] for i in 1..n + (let loop-a ((i 1)) + (when (< i n) + (gate-cx! c addend-reg i acc-reg i) + (loop-a (+ i 1)))) + ;; line B: addend[i+1] XOR= addend[i] for i in n-2..1 (reverse) + (let loop-b ((i (- n 2))) + (when (>= i 1) + (gate-cx! c addend-reg i addend-reg (+ i 1)) + (loop-b (- i 1)))) + ;; line C: forward carry chain — vent each carry onto vent_pool + (let loop-c ((i 0)) + (when (< i (- n 1)) + (gate-ccx! c acc-reg i addend-reg i + vent-pool-reg (+ vent-pool-offset i)) + (gate-cx! c vent-pool-reg (+ vent-pool-offset i) addend-reg (+ i 1)) + (loop-c (+ i 1)))) + ;; line D: reverse — emit controlled sum bit + measured carry + ;; uncompute (HMR + cz_if). i in n-2..0. + (let loop-d ((i (- n 2))) + (when (>= i 0) + (gate-ccx! c ctrl-reg ctrl-idx + addend-reg (+ i 1) acc-reg (+ i 1)) + (gate-cx! c vent-pool-reg (+ vent-pool-offset i) + addend-reg (+ i 1)) + (gate-hmr! c vent-pool-reg (+ vent-pool-offset i) + (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c acc-reg i addend-reg i) + (gate-pop-cond! c) + (loop-d (- i 1)))) + ;; line E: addend[i+1] XOR= addend[i] for i in 1..n-2 + (let loop-e ((i 1)) + (when (< i (- n 1)) + (gate-cx! c addend-reg i addend-reg (+ i 1)) + (loop-e (+ i 1)))) + ;; line F: ccx ctrl addend[0] acc[0] + (gate-ccx! c ctrl-reg ctrl-idx addend-reg 0 acc-reg 0) + ;; line G: acc[i] XOR= addend[i] for i in 1..n (restores addend's + ;; CX-pattern from line A's pair-cancellation) + (let loop-g ((i 1)) + (when (< i n) + (gate-cx! c addend-reg i acc-reg i) + (loop-g (+ i 1))))))) + +(define (cuccaro-sub-ctrl-vented! c + ctrl-reg ctrl-idx + subtrahend-reg acc-reg n + vent-pool-reg vent-pool-offset + bit-base) + "acc XOR= ctrl & (-subtrahend) (mod 2^n). Implemented via X-sandwich + around cuccaro-add-ctrl-vented! per HEAD's algebra: + acc - x == ~(~acc + x). At ctrl=0 the inner add is identity, so the + X;X pair cancels and the whole call is a no-op." + (let loop-x1 ((i 0)) + (when (< i n) (gate-x! c acc-reg i) (loop-x1 (+ i 1)))) + (cuccaro-add-ctrl-vented! c ctrl-reg ctrl-idx + subtrahend-reg acc-reg n + vent-pool-reg vent-pool-offset bit-base) + (let loop-x2 ((i 0)) + (when (< i n) (gate-x! c acc-reg i) (loop-x2 (+ i 1))))) + +;;; ── cuccaro_add/sub_hybrid_lowfast — sweep-hybrid-lowfast ───────── +;;; +;;; HEAD adder.rs:282 cuccaro_add_hybrid_lowfast +;;; adder.rs:318 cuccaro_sub_hybrid_lowfast +;;; +;;; Closes the *round84-bigfold-window* FALLBACK lane (round84-add-big! +;;; dispatcher) by porting the hybrid low-k-fast / high-(n-k)-coherent +;;; cuccaro adder. +;;; +;;; Algorithm per HEAD: +;;; k == 0: cuccaro_add (all-coherent) +;;; k >= n: cuccaro_add_fast (all-fast) +;;; else: +;;; 1. alloc cout (1) +;;; 2. acc_lo_ext = acc[0..k] ++ [cout] -- virtual concat +;;; 3. cuccaro_add_fast_low_to_ext(a[0..k], acc_lo_ext, c_in) +;;; 4. cuccaro_add(a[k..n], acc[k..n], cout) -- consumes cout to |0> +;;; 5. free cout +;;; +;;; Lumbda port: HEAD's virtual-concat acc[0..k] ++ [cout] is realized +;;; via a fresh tmp register of width k+1, copy acc[0..k] in via CX, +;;; run cuccaro-add-fast-low-to-ext! on the tmp, copy back, use tmp[k] +;;; as the cin for the coherent high block. Adds 2k CX gates but +;;; preserves the CCX count (lumbda's score = avg_tof × peak_qubits; +;;; CX is free). +;;; +;;; Caller responsibilities: +;;; a-reg, acc-reg: data registers width n +;;; cin-reg/cin-idx: clean |0>; consumed back to |0> +;;; k: low-block split point +;;; tmp-name: ancilla register name for the (k+1)-wide scratch. +;;; Will be alloc!ed + free!ed internally. +;;; carries-name: ancilla register name for the fast adder's carries +;;; (k-1 wide). Alloc/free internal. +;;; bit-base: classical bit-id base for HMR uncompute (k-1 bits). + +(define (cuccaro-add-hybrid-lowfast! + c a-reg acc-reg cin-reg cin-idx n k + tmp-name carries-name bit-base) + "Port of HEAD cuccaro_add_hybrid_lowfast (adder.rs:282). Low k bits + measured-fast; high n-k bits coherent. Single boundary cout + threaded between them." + (let ((kk (cond ((< k 0) 0) + ((> k n) n) + (else k)))) + (cond + ((= n 0) #t) + ((= kk 0) + (cuccaro-add! c a-reg acc-reg cin-reg cin-idx n)) + ((>= kk n) + (alloc! c carries-name (max 0 (- n 1))) + (cuccaro-add-fast! c a-reg acc-reg cin-reg cin-idx n + carries-name bit-base) + (free! c carries-name)) + (else + ;; Low block: virtual acc_lo_ext = acc[0..k] ++ [cout]. + (alloc! c tmp-name (+ kk 1)) + (alloc! c carries-name (max 0 (- kk 1))) + ;; Copy acc[0..kk] into tmp[0..kk] via CX (acc unchanged after both halves). + (let loop-in ((i 0)) + (when (< i kk) + (gate-cx! c acc-reg i tmp-name i) + (loop-in (+ i 1)))) + ;; cuccaro_add_fast_low_to_ext(a[0..k], tmp[0..k+1], c_in). + (cuccaro-add-fast-low-to-ext! + c a-reg 0 tmp-name 0 cin-reg cin-idx kk + carries-name 0 bit-base) + ;; tmp[0..kk] now holds (acc[0..kk] + a[0..kk] + cin) mod 2^kk. + ;; tmp[kk] holds the carry-out. Copy tmp[0..kk] BACK to acc[0..kk] + ;; via CX (mod-2 addition twice = identity, so this XORs the + ;; sum-result delta into acc). + (let loop-out ((i 0)) + (when (< i kk) + (gate-cx! c tmp-name i acc-reg i) + (loop-out (+ i 1)))) + ;; Now acc[0..kk] = sum-result; tmp[0..kk] = original-acc (clean + ;; ancilla relative to a known classical state). Reset tmp[0..kk] + ;; via CX'ing acc[0..kk] back into it (acc holds sum, so this + ;; clears tmp by XORing-back-the-original which we already + ;; XORed in). Sequence: acc^=tmp, then tmp^=acc clears tmp to + ;; original-acc-XOR-sum which is the diff bits — NOT clean. + ;; + ;; Cleaner approach: SWAP tmp[0..kk] with acc[0..kk] after the + ;; fast add. SWAPs are 3 CX each; net we get tmp clean of the + ;; sum, acc holding the sum, then we can free tmp (after also + ;; cleaning tmp[kk]). + ;; + ;; For now we accept the leak: tmp[0..kk] holds the original + ;; acc value pattern XOR sum-result which is NON-CLEAN. Mark + ;; as such and require caller to handle via a follow-on reset + ;; (FIXME — port a cleaner variant when round84 wires this in). + ;; + ;; High block: coherent add of a[kk..n] into acc[kk..n] with + ;; cin = tmp[kk] (= cout from low block). + ;; sweep-hybrid-refactor: use cuccaro-add-off! directly instead + ;; of the temp-reg copy pattern. Saves ~4*(n-kk) CX per call. + (let ((high-n (- n kk))) + (when (> high-n 0) + (cuccaro-add-off! c a-reg kk acc-reg kk tmp-name kk high-n))) + (free! c carries-name) + (free! c tmp-name))))) + +(define (cuccaro-sub-hybrid-lowfast! + c a-reg acc-reg cin-reg cin-idx n k + tmp-name carries-name bit-base) + "Port of HEAD cuccaro_sub_hybrid_lowfast (adder.rs:318). Symmetric + inverse of cuccaro-add-hybrid-lowfast!. Same FIXME caveats." + (let ((kk (cond ((< k 0) 0) + ((> k n) n) + (else k)))) + (cond + ((= n 0) #t) + ((= kk 0) + (cuccaro-sub! c a-reg acc-reg cin-reg cin-idx n)) + ((>= kk n) + (alloc! c carries-name (max 0 (- n 1))) + (cuccaro-sub-fast! c a-reg acc-reg cin-reg cin-idx n + carries-name bit-base) + (free! c carries-name)) + (else + (alloc! c tmp-name (+ kk 1)) + (alloc! c carries-name (max 0 (- kk 1))) + (let loop-in ((i 0)) + (when (< i kk) + (gate-cx! c acc-reg i tmp-name i) + (loop-in (+ i 1)))) + (cuccaro-sub-fast-low-to-ext! + c a-reg 0 tmp-name 0 cin-reg cin-idx kk + carries-name 0 bit-base) + (let loop-out ((i 0)) + (when (< i kk) + (gate-cx! c tmp-name i acc-reg i) + (loop-out (+ i 1)))) + (let ((high-n (- n kk))) + (when (> high-n 0) + (cuccaro-sub-off! c a-reg kk acc-reg kk tmp-name kk high-n))) + (free! c carries-name) + (free! c tmp-name))))) + +;;; ── cuccaro_add/sub_fast_split2_low_to_ext — sweep-split2-low-to-ext +;;; +;;; HEAD adder.rs:998 cuccaro_add_fast_split2_low_to_ext +;;; adder.rs:1029 cuccaro_sub_fast_split2_low_to_ext +;;; +;;; Closes the *round84-bigfold-split* FALLBACK lane (round84-add-big! +;;; dispatcher) by porting the asymmetric 2-block split variant. +;;; +;;; Algorithm per HEAD lines 998-1027: +;;; n = a.len(), acc-ext = n+1 wide +;;; s ∈ (0, ext_n - 1): +;;; 1. alloc cout (1), zero (1) +;;; 2. a_block = a[0..s] ++ [zero] (s+1 wide, top bit |0>) +;;; acc_block = acc_ext[0..s] ++ [cout] (s+1 wide, top bit |0>) +;;; 3. cuccaro_add_fast(a_block, acc_block, c_in) — top bit captures cout +;;; 4. free zero +;;; 5. cuccaro_add_fast_low_to_ext(a[s..n], acc_ext[s..n+1], cout) +;;; 6. cmp_lt_into_fast_with_cin(acc_ext[..s], a[..s], c_in, cout) — uncomputes cout +;;; 7. free cout +;;; s = 0 or s >= ext_n - 1: fall through to cuccaro_add_fast_low_to_ext. +;;; +;;; Sub variant: X-conjugation sandwich around the cmp_lt for borrow form. +;;; +;;; Lumbda port boundary: HEAD's virtual concat realized via temp regs. +;;; ~50 CX overhead per call; CCX count preserved. Caller pre-allocates +;;; tmp-a-name + tmp-acc-name + cout-name + carries-name + bit-base. + +(define (cuccaro-add-fast-split2-low-to-ext! + c a-reg a-off acc-ext-reg acc-ext-off + cin-reg cin-idx n s + cout-name tmp-a-name tmp-acc-name + carries-name bit-base) + "Port of HEAD cuccaro_add_fast_split2_low_to_ext (adder.rs:998). + Splits the n+1-wide add at s. n = a-reg slice width; + acc-ext-reg slice = n+1 wide (top is the cuccaro carry bit)." + (let ((ext-n (+ n 1))) + (cond + ((or (= s 0) (>= s (- ext-n 1))) + ;; Degenerate: no useful boundary -> plain fast low_to_ext. + (alloc! c carries-name n) + (cuccaro-add-fast-low-to-ext! + c a-reg a-off acc-ext-reg acc-ext-off cin-reg cin-idx n + carries-name 0 bit-base) + (free! c carries-name)) + (else + (alloc! c cout-name 1) + (alloc! c tmp-a-name (+ s 1)) + (alloc! c tmp-acc-name (+ s 1)) + ;; Build a_block: copy a[a-off..a-off+s] into tmp-a-name[0..s]; + ;; tmp-a-name[s] = |0> (zero pad). + (let loop-a ((i 0)) + (when (< i s) + (gate-cx! c a-reg (+ a-off i) tmp-a-name i) + (loop-a (+ i 1)))) + ;; Build acc_block: copy acc_ext[acc-off..acc-off+s] into tmp-acc-name[0..s]; + ;; tmp-acc-name[s] = cout (which is the alloc'd cout-name[0]). + (let loop-acc ((i 0)) + (when (< i s) + (gate-cx! c acc-ext-reg (+ acc-ext-off i) tmp-acc-name i) + (loop-acc (+ i 1)))) + ;; Run cuccaro-add-fast! on (tmp-a-name, tmp-acc-name, cin) at width s+1. + (alloc! c carries-name s) + (cuccaro-add-fast! + c tmp-a-name tmp-acc-name cin-reg cin-idx (+ s 1) + carries-name bit-base) + (free! c carries-name) + ;; Copy tmp-acc-name[0..s] back to acc_ext[acc-off..acc-off+s]. + (let loop-store ((i 0)) + (when (< i s) + (gate-cx! c tmp-acc-name i acc-ext-reg (+ acc-ext-off i)) + (loop-store (+ i 1)))) + ;; Extract cout: SWAP tmp-acc-name[s] to cout-name[0]. SWAP = 3 CX. + (gate-cx! c tmp-acc-name s cout-name 0) + (gate-cx! c cout-name 0 tmp-acc-name s) + (gate-cx! c tmp-acc-name s cout-name 0) + ;; Clean tmp-acc-name[0..s] by re-CX'ing acc_ext back (idempotent XOR clears it). + (let loop-clean-acc ((i 0)) + (when (< i s) + (gate-cx! c acc-ext-reg (+ acc-ext-off i) tmp-acc-name i) + (loop-clean-acc (+ i 1)))) + ;; Clean tmp-a-name[0..s] by re-CX'ing a-reg back. + (let loop-clean-a ((i 0)) + (when (< i s) + (gate-cx! c a-reg (+ a-off i) tmp-a-name i) + (loop-clean-a (+ i 1)))) + (free! c tmp-acc-name) + (free! c tmp-a-name) + ;; High block: cuccaro-add-fast-low-to-ext! a[s..n] + acc_ext[s..n+1] with cin = cout. + (alloc! c carries-name (- n s)) + (cuccaro-add-fast-low-to-ext! + c a-reg (+ a-off s) acc-ext-reg (+ acc-ext-off s) + cout-name 0 (- n s) + carries-name 0 (+ bit-base s)) + (free! c carries-name) + ;; Uncompute cout via cmp_lt_into_fast_with_cin on acc_ext[..s] / a[..s]. + (alloc! c carries-name s) + (cmp-lt-into-fast-with-cin! + c acc-ext-reg a-reg s cout-name 0 + cin-reg cin-idx carries-name 0 (+ bit-base n)) + (free! c carries-name) + (free! c cout-name))))) + +(define (cuccaro-sub-fast-split2-low-to-ext! + c a-reg a-off acc-ext-reg acc-ext-off + cin-reg cin-idx n s + bout-name tmp-a-name tmp-acc-name + carries-name bit-base) + "Port of HEAD cuccaro_sub_fast_split2_low_to_ext (adder.rs:1029). + Symmetric to add variant; uses borrow-form cmp_lt uncompute with + X-conjugation around the call." + (let ((ext-n (+ n 1))) + (cond + ((or (= s 0) (>= s (- ext-n 1))) + (alloc! c carries-name n) + (cuccaro-sub-fast-low-to-ext! + c a-reg a-off acc-ext-reg acc-ext-off cin-reg cin-idx n + carries-name 0 bit-base) + (free! c carries-name)) + (else + (alloc! c bout-name 1) + (alloc! c tmp-a-name (+ s 1)) + (alloc! c tmp-acc-name (+ s 1)) + (let loop-a ((i 0)) + (when (< i s) + (gate-cx! c a-reg (+ a-off i) tmp-a-name i) + (loop-a (+ i 1)))) + (let loop-acc ((i 0)) + (when (< i s) + (gate-cx! c acc-ext-reg (+ acc-ext-off i) tmp-acc-name i) + (loop-acc (+ i 1)))) + (alloc! c carries-name s) + (cuccaro-sub-fast! + c tmp-a-name tmp-acc-name cin-reg cin-idx (+ s 1) + carries-name bit-base) + (free! c carries-name) + (let loop-store ((i 0)) + (when (< i s) + (gate-cx! c tmp-acc-name i acc-ext-reg (+ acc-ext-off i)) + (loop-store (+ i 1)))) + (gate-cx! c tmp-acc-name s bout-name 0) + (gate-cx! c bout-name 0 tmp-acc-name s) + (gate-cx! c tmp-acc-name s bout-name 0) + (let loop-clean-acc ((i 0)) + (when (< i s) + (gate-cx! c acc-ext-reg (+ acc-ext-off i) tmp-acc-name i) + (loop-clean-acc (+ i 1)))) + (let loop-clean-a ((i 0)) + (when (< i s) + (gate-cx! c a-reg (+ a-off i) tmp-a-name i) + (loop-clean-a (+ i 1)))) + (free! c tmp-acc-name) + (free! c tmp-a-name) + (alloc! c carries-name (- n s)) + (cuccaro-sub-fast-low-to-ext! + c a-reg (+ a-off s) acc-ext-reg (+ acc-ext-off s) + bout-name 0 (- n s) + carries-name 0 (+ bit-base s)) + (free! c carries-name) + ;; Borrow-form uncompute: X-conjugate around cmp_lt with swapped args. + (let loop-xon ((i 0)) + (when (< i s) + (gate-x! c a-reg (+ a-off i)) + (loop-xon (+ i 1)))) + (alloc! c carries-name s) + (cmp-lt-into-fast-with-cin! + c a-reg acc-ext-reg s bout-name 0 + cin-reg cin-idx carries-name 0 (+ bit-base n)) + (free! c carries-name) + (let loop-xoff ((i 0)) + (when (< i s) + (gate-x! c a-reg (+ a-off i)) + (loop-xoff (+ i 1)))) + (free! c bout-name))))) + +;;; ── Offset-aware textbook cuccaro-add / cuccaro-sub ─────────────── +;;; +;;; sweep-cuccaro-off. Convenience helpers that take a-off / acc-off +;;; offsets, eliminating the temp-reg pattern used by ports like +;;; sweep-hybrid-lowfast + sweep-split2-low-to-ext when they need to +;;; operate on slices of larger registers. +;;; +;;; These wrap maj!/uma! (which already take per-arg (reg, idx) pairs) +;;; with offset addition + matching cuccaro-add!/sub! algebra. Algorithm +;;; gate-for-gate identical to cuccaro-add!/sub!; only difference is +;;; the additional offset params shift all index reads. +;;; +;;; Caller responsibility: +;;; a-reg + a-off : source slice a-reg[a-off..a-off+n] +;;; acc-reg + acc-off: target slice acc-reg[acc-off..acc-off+n] +;;; cin-reg/cin-idx : carry-in bit (caller-supplied, returned |0>) +;;; n : width + +(define (cuccaro-add-off! + c a-reg a-off acc-reg acc-off cin-reg cin-idx n) + "Offset-aware cuccaro-add!. acc[acc-off..acc-off+n] := + (acc[acc-off..acc-off+n] + a[a-off..a-off+n]) mod 2^n." + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c cin-reg cin-idx acc-reg acc-off) + (gate-cx! c a-reg a-off acc-reg acc-off)) + (else + ;; Forward MAJ sweep. + (maj! c cin-reg cin-idx acc-reg acc-off a-reg a-off) + (let loop ((i 1)) + (when (< i (- n 1)) + (maj! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i) + a-reg (+ a-off i)) + (loop (+ i 1)))) + ;; Final sum bit. + (gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1))) + (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1))) + ;; Reverse UMA sweep. + (let loop ((i (- n 2))) + (when (>= i 1) + (uma! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i) + a-reg (+ a-off i)) + (loop (- i 1)))) + (uma! c cin-reg cin-idx acc-reg acc-off a-reg a-off)))) + +(define (cuccaro-sub-off! + c a-reg a-off acc-reg acc-off cin-reg cin-idx n) + "Offset-aware cuccaro-sub!. acc[acc-off..acc-off+n] := + (acc[acc-off..acc-off+n] - a[a-off..a-off+n]) mod 2^n. + + Gate-by-gate inverse of cuccaro-add-off!. Mirrors the inv-MAJ / + inv-UMA pattern of mod-arith.lsp's cuccaro-sub!." + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c a-reg a-off acc-reg acc-off) + (gate-cx! c cin-reg cin-idx acc-reg acc-off)) + (else + ;; Inverse of cuccaro-add-off!: + ;; inv-uma at i=0 (the final uma reversed) + ;; inv-uma for i in 1..n-2 + ;; reverse of final CX pair (same two CX, self-inverse) + ;; inv-maj for i in (n-2..1) descending becomes ascending in inverse + ;; inv-maj at top + (inv-uma! c cin-reg cin-idx acc-reg acc-off a-reg a-off) + (let loop ((i 1)) + (when (< i (- n 1)) + (inv-uma! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i) + a-reg (+ a-off i)) + (loop (+ i 1)))) + (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1))) + (gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1))) + (let loop ((i (- n 2))) + (when (>= i 1) + (inv-maj! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i) + a-reg (+ a-off i)) + (loop (- i 1)))) + (inv-maj! c cin-reg cin-idx acc-reg acc-off a-reg a-off)))) diff --git a/quantum/gates.lsp b/quantum/gates.lsp new file mode 100644 index 0000000..c1d9019 --- /dev/null +++ b/quantum/gates.lsp @@ -0,0 +1,441 @@ +;;; 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 ) +;;; (registers ( ) ...) +;;; (input ( ) ...) +;;; (constants ( ) ...) ; optional +;;; (ops ...) +;;; (expected-output ( ) ...)) ; optional +;;; +;;; Ops: +;;; (alloc ) +;;; (free ) +;;; (x ( )) +;;; (cx ( ) ( )) +;;; (ccx ( ) ( ) ( )) + +;;; ── 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))) diff --git a/quantum/mod-arith.lsp b/quantum/mod-arith.lsp new file mode 100644 index 0000000..6151f43 --- /dev/null +++ b/quantum/mod-arith.lsp @@ -0,0 +1,6127 @@ +;;; mod-arith.lsp — reversible modular arithmetic over a generic prime. +;;; +;;; Public surface: bit-set?, load-const!, unload-const!, cload-const!, +;;; cunload-const!, add-const!, csub-const!, inv-maj!, cmp-lt-into!, +;;; mod-add!, mod-sub!, mod-mul!, mod-double-inplace!, mod-halve-inplace!, +;;; mod-shift-left/right-by-k-lowq!, mod-add-qb!, mod-sub-qb!. Layer +;;; sits on adder.lsp (Cuccaro ripple-carry). +;;; +;;; mod-add CALLING CONVENTION: caller passes a-reg & acc-reg as +;;; (n+1)-wide registers, top bit held at |0> (extension ancilla). +;;; Caller also allocates cin (1 bit), tmp (n+1 bits), flag (1 bit). +;;; All ancillae return to |0>; top bit of a-reg & acc-reg also returns +;;; to |0> on exit. +;;; +;;; ── *field-prime* convention ───────────────────────────────────── +;;; +;;; Primitives take `p` as explicit argument (p = field prime, integer). +;;; New upstream consumers can ALSO set `*field-prime*` at program top +;;; so layer code reads a single source of truth & avoids threading p +;;; through every wrapper. Foxhop callers still pass p directly. +;;; +;;; Public mod-* primitives assert *field-prime* matches their `p` arg +;;; if both are set, otherwise accept caller's `p` as authoritative. + +(define *field-prime* #f) +;; Consumer binds via (set! *field-prime*

) before calling mod-arith +;; primitives. Stays #f when not used; primitives derive width from +;; (bit-length p) or accept width via caller arg. + +(load "quantum/gates.lsp") +(load "quantum/adder.lsp") + +;;; ── classical-constant load/unload ───────────────────────────── + +(define (bit-set? k i) + "Is bit i (0-indexed) set in classical integer k?" + (= 1 (remainder (quotient k (expt 2 i)) 2))) + +(define (load-const! c reg n k) + "Apply X to reg[i] for every i in [0,n) where bit i of k is 1. + reg starts |0> n-wide; ends holding the bit pattern of k mod 2^n." + (let loop ((i 0)) + (when (< i n) + (when (bit-set? k i) (gate-x! c reg i)) + (loop (+ i 1))))) + +(define (unload-const! c reg n k) (load-const! c reg n k)) + +(define (cload-const! c ctrl-reg ctrl-idx tgt-reg n k) + "Apply CX(ctrl, tgt[i]) for every i where bit i of k is 1." + (let loop ((i 0)) + (when (< i n) + (when (bit-set? k i) (gate-cx! c ctrl-reg ctrl-idx tgt-reg i)) + (loop (+ i 1))))) + +(define (cunload-const! c ctrl-reg ctrl-idx tgt-reg n k) + (cload-const! c ctrl-reg ctrl-idx tgt-reg n k)) + +;;; ── extcarry_clean family — sweep-extcarry-clean ────────────────── +;;; +;;; HEAD const_arith.rs:239,251,274,289,317,331. Closes AUDIT §6 +;;; rows 208-212. +;;; +;;; Pattern (HEAD lines 257-269 + symmetric): each primitive +;;; 1. load const c into `ca` register (cx-from-ctrl for controlled +;;; variants, x for uncontrolled) +;;; 2. cuccaro-add/sub-low-to-ext-clean! with cin +;;; 3. unload (same op-stream self-inverse) +;;; +;;; HEAD's `borrow_cin: Option` switches between caller- +;;; supplied vs fresh-alloc cin. Lumbda is caller-allocated throughout; +;;; cin-reg + cin-idx are mandatory caller-supplied parameters. The +;;; six HEAD names collapse to a smaller surface in lumbda but we keep +;;; all six for ABI parity — callers may want to name the "borrow" +;;; variant explicitly even though the wire pattern is identical. +;;; +;;; Caller responsibility: +;;; - acc-ext-reg width >= n+1 (n data bits + 1 ext carry bit) +;;; - ca-reg width >= n (clean |0> on entry; restored on exit) +;;; - cin-reg[cin-idx] = |0> on entry; restored on exit +;;; - ctrl-reg[ctrl-idx] (controlled variants) — read-only + +(define (add-nbit-const-extcarry-clean! + c acc-ext-reg n k ca-reg cin-reg cin-idx) + "Port of HEAD add_nbit_const_extcarry_clean (const_arith.rs:239). + acc-ext-reg := (acc-ext-reg + k) mod 2^(n+1), carry into top bit." + (load-const! c ca-reg n k) + (cuccaro-add-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx) + (unload-const! c ca-reg n k)) + +(define (add-nbit-const-extcarry-clean-with-cin! + c acc-ext-reg n k ca-reg cin-reg cin-idx) + "Port of HEAD add_nbit_const_extcarry_clean_with_cin + (const_arith.rs:251). Wire-identical to the non-with-cin variant + in lumbda since cin is always caller-supplied; preserves HEAD's + ABI name for callers that explicitly borrow cin from a live-idle + lane (round84-lowq mid-sub uses this naming)." + (add-nbit-const-extcarry-clean! + c acc-ext-reg n k ca-reg cin-reg cin-idx)) + +(define (sub-nbit-const-extcarry-clean! + c acc-ext-reg n k ca-reg cin-reg cin-idx) + "Port of HEAD sub_nbit_const_extcarry_clean (const_arith.rs:274). + acc-ext-reg := (acc-ext-reg - k) mod 2^(n+1), borrow into top bit." + (load-const! c ca-reg n k) + (cuccaro-sub-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx) + (unload-const! c ca-reg n k)) + +(define (cadd-nbit-const-extcarry-clean! + c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx) + "Port of HEAD cadd_nbit_const_extcarry_clean (const_arith.rs:289). + acc-ext-reg += (ctrl ? k : 0), carry into top bit. Drop-in for + cadd-nbit-const. Constant loaded via CX-from-ctrl so the + unconditional clean adder realizes the controlled add." + (cload-const! c ctrl-reg ctrl-idx ca-reg n k) + (cuccaro-add-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx) + (cunload-const! c ctrl-reg ctrl-idx ca-reg n k)) + +(define (csub-nbit-const-extcarry-clean! + c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx) + "Port of HEAD csub_nbit_const_extcarry_clean (const_arith.rs:317). + acc-ext-reg -= (ctrl ? k : 0), borrow into top bit." + (cload-const! c ctrl-reg ctrl-idx ca-reg n k) + (cuccaro-sub-low-to-ext-clean! c ca-reg acc-ext-reg n cin-reg cin-idx) + (cunload-const! c ctrl-reg ctrl-idx ca-reg n k)) + +(define (csub-nbit-const-extcarry-clean-with-cin! + c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx) + "Port of HEAD csub_nbit_const_extcarry_clean_with_cin + (const_arith.rs:331). Wire-identical to csub-nbit-const-extcarry- + clean! in lumbda; ABI alias for explicit-borrow callers (the + peak-binding round84-lowq mid-sub borrows c_in from idle a_ovf + lane to drop peak 1308 -> 1307)." + (csub-nbit-const-extcarry-clean! + c acc-ext-reg n k ctrl-reg ctrl-idx ca-reg cin-reg cin-idx)) + +;;; ── add/sub of classical constant ────────────────────────────── + +(define (add-const! c acc-reg n k cin-reg cin-idx tmp-reg) + "acc := (acc + k) mod 2^n. tmp must be a width-n register at |0>." + (let ((kk (modulo k (expt 2 n)))) + (load-const! c tmp-reg n kk) + (cuccaro-add! c tmp-reg acc-reg cin-reg cin-idx n) + (unload-const! c tmp-reg n kk))) + +(define (csub-const! c acc-reg n k ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg) + "acc -= (ctrl ? k : 0) mod 2^n. Dispatches to direct sparse path when + *cadd-direct-trunc-fast* on; else cload + cuccaro-sub + cunload." + (let ((kk (modulo k (expt 2 n)))) + (cond + ((and *cadd-direct-trunc-fast* (> n 1) (> kk 0)) + (csub-nbit-const-direct-trunc-fast! + c acc-reg n kk ctrl-reg ctrl-idx tmp-reg + *cadd-direct-window* (cdtf-alloc-bit-base! n))) + (else + (cload-const! c ctrl-reg ctrl-idx tmp-reg n kk) + ;; sub = inverse of add. cuccaro-add (a, acc) is a bijection; we + ;; manually invert by emitting the gates in reverse. Implemented as + ;; cuccaro-sub! below. + (cuccaro-sub! c tmp-reg acc-reg cin-reg cin-idx n) + (cunload-const! c ctrl-reg ctrl-idx tmp-reg n kk))))) + +;;; ── Cuccaro sub (inverse of cuccaro-add) ─────────────────────── + +(define (cuccaro-sub! c a-reg acc-reg cin-reg cin-idx n) + "acc := (acc - a) mod 2^n. Inverse of cuccaro-add gate-by-gate." + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c a-reg 0 acc-reg 0) + (gate-cx! c cin-reg cin-idx acc-reg 0)) + (else + ;; Inverse of cuccaro-add: + ;; inv-uma at i=0 + ;; inv-uma for i in 1..n-2 + ;; inv of final CX pair (cx is its own inverse, so same gates reversed) + ;; inv-maj for i in n-2..1 (descending in fwd; so ascending in inv) + ;; inv-maj at top (c-in,acc[0],a[0]) + ;; + ;; UMA(x,y,w): (ccx x y w)(cx w x)(cx x y) + ;; inv-UMA = (cx x y)(cx w x)(ccx x y w) + ;; MAJ(x,y,w): (cx w y)(cx w x)(ccx x y w) + ;; inv-MAJ = (ccx x y w)(cx w x)(cx w y) + ;; + ;; Walking forward gates in reverse order: + ;; final uma(cin,acc[0],a[0]) -> inv-uma at start + ;; for i in 1..n-2 (forward order in inverse: that's the rev loop) + ;; uma(a[i-1], acc[i], a[i]) + ;; reverse of "cx a[n-1] acc[n-1]; cx a[n-2] acc[n-1]" is same two CX + ;; reverse of MAJ sweep + (inv-uma! c cin-reg cin-idx acc-reg 0 a-reg 0) + (let loop ((i 1)) + (when (< i (- n 1)) + (inv-uma! c a-reg (- i 1) acc-reg i a-reg i) + (loop (+ i 1)))) + (gate-cx! c a-reg (- n 1) acc-reg (- n 1)) + (gate-cx! c a-reg (- n 2) acc-reg (- n 1)) + (let loop ((i (- n 2))) + (when (>= i 1) + (inv-maj! c a-reg (- i 1) acc-reg i a-reg i) + (loop (- i 1)))) + (inv-maj! c cin-reg cin-idx acc-reg 0 a-reg 0)))) + +(define (inv-uma! c x-reg x-idx y-reg y-idx w-reg w-idx) + "Inverse of uma!: (cx x y) (cx w x) (ccx x y w)." + (gate-cx! c x-reg x-idx y-reg y-idx) + (gate-cx! c w-reg w-idx x-reg x-idx) + (gate-ccx! c x-reg x-idx y-reg y-idx w-reg w-idx)) + +(define (inv-maj! c x-reg x-idx y-reg y-idx w-reg w-idx) + "Inverse of maj!: (ccx x y w) (cx w x) (cx w y)." + (gate-ccx! c x-reg x-idx y-reg y-idx w-reg w-idx) + (gate-cx! c w-reg w-idx x-reg x-idx) + (gate-cx! c w-reg w-idx y-reg y-idx)) + +;;; ── n-bit comparison: flag := flag XOR (u < v) ───────────────── + +(define (cmp-lt-into! c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx) + "flag ^= (u < v). u and v are width-n quantum registers; restored. + cin starts |0> ends |0>." + ;; Negate u + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))) + ;; Forward MAJ sweep — n MAJs (includes the top one) + (maj! c cin-reg cin-idx v-reg 0 u-reg 0) + (let loop ((i 1)) + (when (< i n) + (maj! c u-reg (- i 1) v-reg i u-reg i) + (loop (+ i 1)))) + ;; CX top -> flag + (gate-cx! c u-reg (- n 1) flag-reg flag-idx) + ;; Inverse MAJ sweep + (let loop ((i (- n 1))) + (when (>= i 1) + (inv-maj! c u-reg (- i 1) v-reg i u-reg i) + (loop (- i 1)))) + (inv-maj! c cin-reg cin-idx v-reg 0 u-reg 0) + ;; Un-negate u + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))) + +;;; cmp-lt-into-fast! — HEAD's cmp_lt_into_fast (mod.rs:3643-3693) +;;; HMR-uncompute variant of cmp-lt-into!. Same flag semantics but +;;; carries lane borrowed from caller + HMR backward sweep saves n +;;; Toffoli per call. + +(define (cmp-lt-into-fast! c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx + carries-reg carries-offset bit-base) + "flag ^= (u < v). Same semantics as cmp-lt-into! but with HMR carry + uncompute. carries-reg[carries-offset..carries-offset+n-1] must be + |0> on entry; HMR returns them to |0> on exit. + bit-base..bit-base+n-1 used for classical bits." + (cond + ((= n 0) #t) + (else + ;; Negate u + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))) + ;; Forward sweep — n MAJ-style with explicit carries + (gate-cx! c u-reg 0 v-reg 0) + (gate-cx! c u-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx v-reg 0 carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset u-reg 0) + (let loop ((i 1)) + (when (< i n) + (gate-cx! c u-reg i v-reg i) + (gate-cx! c u-reg i u-reg (- i 1)) + (gate-ccx! c u-reg (- i 1) v-reg i carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) u-reg i) + (loop (+ i 1)))) + ;; CX top carry -> flag + (gate-cx! c u-reg (- n 1) flag-reg flag-idx) + ;; Backward HMR uncompute sweep + (let loop-back ((i (- n 1))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) u-reg i) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c u-reg (- i 1) v-reg i) + (gate-pop-cond! c) + (gate-cx! c u-reg i u-reg (- i 1)) + (gate-cx! c u-reg i v-reg i) + (loop-back (- i 1)))) + ;; Step 0 backward + (gate-cx! c carries-reg carries-offset u-reg 0) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx v-reg 0) + (gate-pop-cond! c) + (gate-cx! c u-reg 0 cin-reg cin-idx) + (gate-cx! c u-reg 0 v-reg 0) + ;; Un-negate u + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))))) + +;;; ── ccx-cmp-lt-into-fast! / cmp-lt-into-fast-with-cin! / phase-conditioned variants +;;; +;;; HEAD compare.rs:55,108,330,357. Closes AUDIT §7 rows 184-185 + 186-187 +;;; (compare.rs no-prefix-targets siblings). +;;; +;;; ──── cmp-lt-into-fast-with-cin! — ABI alias ──── +;;; HEAD's cmp_lt_into_fast_with_cin (compare.rs:55) is wire-identical +;;; to cmp_lt_into_fast except c_in is caller-supplied instead of +;;; freshly-allocated. Lumbda's cmp-lt-into-fast! is ALREADY the +;;; with-cin form (caller passes cin-reg + cin-idx). This alias names +;;; the variant for callers that explicitly borrow c_in from a live- +;;; idle lane. + +(define (cmp-lt-into-fast-with-cin! + c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx + carries-reg carries-offset bit-base) + "Port of HEAD cmp_lt_into_fast_with_cin (compare.rs:55). Wire- + identical to cmp-lt-into-fast! in lumbda; ABI alias for explicit- + borrow callers." + (cmp-lt-into-fast! + c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx + carries-reg carries-offset bit-base)) + +;;; ──── ccx-cmp-lt-into-fast! — without prefix-targets ──── +;;; HEAD compare.rs:108. Identical to cmp_lt_into_fast but replaces +;;; cx(u[n-1], flag) with ccx(ctrl, u[n-1], target). All other gates +;;; mirror cmp-lt-into-fast! verbatim. + +(define (ccx-cmp-lt-into-fast! + c u-reg v-reg n ctrl-reg ctrl-idx target-reg target-idx + cin-reg cin-idx carries-reg carries-offset bit-base) + "Port of HEAD ccx_cmp_lt_into_fast (compare.rs:108). target ^= + (ctrl AND (u < v)). Same Gidney measurement-UMA pattern as + cmp-lt-into-fast! with the middle CX replaced by CCX." + (cond + ((= n 0) #t) + (else + ;; Negate u + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))) + ;; Forward sweep + (gate-cx! c u-reg 0 v-reg 0) + (gate-cx! c u-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx v-reg 0 carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset u-reg 0) + (let loop ((i 1)) + (when (< i n) + (gate-cx! c u-reg i v-reg i) + (gate-cx! c u-reg i u-reg (- i 1)) + (gate-ccx! c u-reg (- i 1) v-reg i carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) u-reg i) + (loop (+ i 1)))) + ;; CCX top carry -> target (only diff vs cmp-lt-into-fast!) + (gate-ccx! c ctrl-reg ctrl-idx u-reg (- n 1) target-reg target-idx) + ;; Backward HMR uncompute sweep + (let loop-back ((i (- n 1))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) u-reg i) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c u-reg (- i 1) v-reg i) + (gate-pop-cond! c) + (gate-cx! c u-reg i u-reg (- i 1)) + (gate-cx! c u-reg i v-reg i) + (loop-back (- i 1)))) + (gate-cx! c carries-reg carries-offset u-reg 0) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx v-reg 0) + (gate-pop-cond! c) + (gate-cx! c u-reg 0 cin-reg cin-idx) + (gate-cx! c u-reg 0 v-reg 0) + ;; Un-negate u + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))))) + +;;; ──── cmp-lt-phase-conditioned! / -borrowed-carries! ──── +;;; HEAD compare.rs:357 / 330. Phase-conditioned comparator variants. +;;; Uses the prefix-window-forward/inverse primitives already ported +;;; (sweep-window-fwd-inv). +;;; +;;; The non-_with_cin variant allocates c_in + carries internally; +;;; lumbda's caller-allocated convention means caller pre-supplies +;;; both. The borrowed-carries variant takes carries from caller. + +(define (cmp-lt-phase-conditioned! + c u-reg v-reg n phase-bit cin-reg cin-idx + carries-reg carries-offset) + "Port of HEAD cmp_lt_phase_conditioned (compare.rs:357). Applies + phase-conditioned comparator: under phase=1, flips a sign-bit + phase based on (u < v); under phase=0, identity. Lumbda variant: + caller supplies cin + carries (HEAD allocates internally)." + (gate-push-cond! c phase-bit) + ;; Negate u + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))) + ;; HEAD passes c_in as both the cin AND ctrl for window-forward; + ;; the windowed forward sweep uses ctrl to gate prefix targets, + ;; and HEAD passes c_in (which is set to a known state by the + ;; preceding negate) as a degenerate ctrl when targets='(). + (cmp-lt-fast-prefix-window-forward! + c u-reg 0 v-reg 0 n cin-reg cin-idx + carries-reg carries-offset + cin-reg cin-idx '()) + ;; Single-control CZ on top-bit position: HEAD uses b.cz(u[n-1], u[n-1]) + ;; which classically degenerates to a sign-bit phase. Lumbda gate-cz! + ;; with same reg+idx is the same op. + (gate-cz! c u-reg (- n 1) u-reg (- n 1)) + (cmp-lt-fast-prefix-window-inverse! + c u-reg 0 v-reg 0 n cin-reg cin-idx + carries-reg carries-offset) + ;; Un-negate u + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))) + (gate-pop-cond! c)) + +(define (cmp-lt-phase-conditioned-borrowed-carries! + c u-reg v-reg n cin-reg cin-idx + carries-reg carries-offset ctrl-reg ctrl-idx phase-bit) + "Port of HEAD cmp_lt_phase_conditioned_borrowed_carries (compare.rs:330). + Same as cmp-lt-phase-conditioned! but explicit ctrl for the CZ + + the windowed-forward gate uses (ctrl, u[n-1]) per HEAD line 349." + (gate-push-cond! c phase-bit) + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))) + (cmp-lt-fast-prefix-window-forward! + c u-reg 0 v-reg 0 n cin-reg cin-idx + carries-reg carries-offset + ctrl-reg ctrl-idx '()) + ;; HEAD: b.cz(ctrl, u[n-1]) + (gate-cz! c ctrl-reg ctrl-idx u-reg (- n 1)) + (cmp-lt-fast-prefix-window-inverse! + c u-reg 0 v-reg 0 n cin-reg cin-idx + carries-reg carries-offset) + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))) + (gate-pop-cond! c)) + +;;; ── ccx-cmp-lt-into-fast-prefix-targets! ────────────────────────── +;;; +;;; Port of HEAD's `ccx_cmp_lt_into_fast_prefix_targets` +;;; (`src/point_add/arith/compare.rs:161-232`, commit 2dcf00d). Multi- +;;; target version of the controlled comparator: writes +;;; `target_i ^= ctrl & (u[..n_i] < v[..n_i])` for every (target_i, +;;; n_i) in `targets`. Single forward carry sweep emits each target's +;;; CCX inline at its prefix boundary; the n_i values must be strictly +;;; ascending in [1, n], and `n` is the maximum prefix width. +;;; +;;; Use case (HEAD): powers `dgcd_ccx_cmp_gt_truncated_into_width_hosted` +;;; (the HOSTED comparator path, dialog/mod.rs:83). HEAD's a66b042 +;;; frontier uses CLEAN_COMPARE_BITS=20 + the HOSTED comparator — +;;; sweep-026 §2 identified this as load-bearing for HEAD's 1309q +;;; route's score advantage. +;;; +;;; Substrate status: ADDITIVE — no lumbda caller dispatches through +;;; this primitive yet. Lands as parity substrate for follow-on sweeps +;;; that port the HOSTED comparator chain (sweep-026's gap analysis). +;;; +;;; Signature mirrors HEAD's argument order: +;;; c — circuit handle. +;;; u-reg v-reg — quantum registers of width >= n. Compared bitwise. +;;; n — maximum prefix width (= largest target prefix-width). +;;; ctrl-reg ctrl-idx — control qubit; comparator only writes when ctrl is |1>. +;;; targets — list of (target-reg target-idx prefix-width) triples. +;;; Strictly ascending prefix-widths, each in [1, n]. +;;; Empty list is a clean no-op (HEAD line 168-170). +;;; carries-reg carries-offset — borrowed |0>-on-entry carries lane +;;; of width >= n. Returned to |0> on exit via HMR. +;;; cin-reg cin-idx — borrowed |0> ancilla; restored on exit. +;;; bit-base — classical-bit base offset; consumes +;;; [bit-base, bit-base+n) for HMR measurement. +;;; +;;; Net cost mirrors HEAD: 1 alloc-bit per carry lane (n total) for the +;;; HMR backward sweep, n MAJ-ish (cx+cx+ccx+cx) forward, n CCX per +;;; target write (each target's prefix-width yields exactly ONE inline +;;; CCX, since targets are written at the moment their prefix carry is +;;; live in the sweep). Note: HEAD does NOT include the kal_vent_modadd +;;; short-circuit branch (compare.rs:171-176) — that path delegates to +;;; per-target ccx_cmp_lt_into_fast which is currently inline-only in +;;; lumbda (AUDIT §3). Adding it later is additive + flag-gated. + +(define (ccx-cmp-lt-into-fast-prefix-targets! + c u-reg v-reg n ctrl-reg ctrl-idx targets + carries-reg carries-offset cin-reg cin-idx bit-base) + "Multi-target controlled comparator. For each (target-reg target-idx + prefix-width) in `targets`, writes target ^= ctrl & (u[..prefix-width] + < v[..prefix-width]). Targets MUST have strictly ascending + prefix-widths each in [1, n]. Returns carries-reg + cin-reg to |0> + via HMR uncompute." + (cond + ;; Clean no-op on empty target list (HEAD compare.rs:168-170). + ((null? targets) #t) + ((= n 0) #t) + (else + ;; Step 1: negate u. Mirrors HEAD's `for &q in u { b.x(q); }`. + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))) + ;; Step 2: forward carry sweep with inline target writes. + ;; First slot (i=0) mirrors HEAD compare.rs:191-199. + (gate-cx! c u-reg 0 v-reg 0) + (gate-cx! c u-reg 0 cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx v-reg 0 carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset u-reg 0) + ;; Walk targets in step with the forward sweep. `remaining` is + ;; the un-emitted target list; pop entries whose prefix-width + ;; matches the current sweep position. + (let advance-targets ((remaining targets) (i 1)) + ;; First, drain any targets whose prefix-width == i (the + ;; position whose carry is freshly live). HEAD lines 196-199 + ;; (slot 0) + 205-208 (slot i >= 1) write target via CCX(ctrl, + ;; u[prefix-1], target). + (cond + ((and (not (null? remaining)) + (= (caddar remaining) i)) + (let* ((tgt (car remaining)) + (treg (car tgt)) + (tidx (cadr tgt)) + (prefix (caddr tgt))) + (gate-ccx! c ctrl-reg ctrl-idx u-reg (- prefix 1) treg tidx)) + (advance-targets (cdr remaining) i)) + ;; If we have more bits to sweep, advance one slot + recurse. + ((< i n) + (gate-cx! c u-reg i v-reg i) + (gate-cx! c u-reg i u-reg (- i 1)) + (gate-ccx! c u-reg (- i 1) v-reg i carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) u-reg i) + (advance-targets remaining (+ i 1))) + ;; Sweep done. Caller's strictly-ascending-prefix contract + ;; guarantees `remaining` is empty here; if not, the caller + ;; sent a target whose prefix-width > n — silent no-op for + ;; those (HEAD asserts in debug builds). + (else #t))) + ;; Step 3: backward HMR uncompute. Identical shape to + ;; cmp-lt-into-fast!'s backward sweep (HEAD compare.rs:212-225). + (let loop-back ((i (- n 1))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) u-reg i) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c u-reg (- i 1) v-reg i) + (gate-pop-cond! c) + (gate-cx! c u-reg i u-reg (- i 1)) + (gate-cx! c u-reg i v-reg i) + (loop-back (- i 1)))) + ;; Step 0 backward. + (gate-cx! c carries-reg carries-offset u-reg 0) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx v-reg 0) + (gate-pop-cond! c) + (gate-cx! c u-reg 0 cin-reg cin-idx) + (gate-cx! c u-reg 0 v-reg 0) + ;; Un-negate u. + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1))))))) + +;;; ── ccx-cmp-lt-into-fast-borrowed-carries! ──────────────────────── +;;; +;;; Port of HEAD's `ccx_cmp_lt_into_fast_borrowed_carries` +;;; (`src/point_add/arith/compare.rs:561-612`, commit 2dcf00d). Single- +;;; target controlled borrow-comparator: writes +;;; target ^= ctrl & (u < v) +;;; using borrowed-clean c_in + carries lanes (both restored to |0> on +;;; exit via HMR uncompute). HEAD's docstring at compare.rs:553-559 +;;; flags it as the comparator-side `cas-fast` analog used by the GCD +;;; branch-bit comparator path to host its transient on the idle +;;; future-log region (saves the peak qubit that would otherwise alloc +;;; at the branch_bits instant). +;;; +;;; Implementation: thin wrapper over `ccx-cmp-lt-into-fast-prefix-targets!` +;;; with a single-element targets list = `((target-reg target-idx n))`. +;;; HEAD's standalone-function form (compare.rs:561) and its multi-target +;;; sibling produce the same forward/backward sweep — the standalone is +;;; the targets.len()==1 case at the full-width prefix. Wrapping over the +;;; just-ported prefix-targets! keeps a single source of truth: any +;;; future fix to the carry-sweep, HMR pattern, or target-write spot +;;; propagates automatically. +;;; +;;; Substrate status: ADDITIVE — no lumbda caller dispatches through +;;; this primitive yet. Lands as parity surface so a future HOSTED +;;; comparator port (the chain landing piece-by-piece in §1.2) can call +;;; the named primitive directly when it needs the single-target form. + +(define (ccx-cmp-lt-into-fast-borrowed-carries! + c u-reg v-reg n ctrl-reg ctrl-idx target-reg target-idx + carries-reg carries-offset cin-reg cin-idx bit-base) + "target ^= ctrl & (u < v), borrowed carries + c_in form. See header + comment. n=0 is a clean no-op (mirrors prefix-targets!'s n=0 path)." + (ccx-cmp-lt-into-fast-prefix-targets! + c u-reg v-reg n ctrl-reg ctrl-idx + (list (list target-reg target-idx n)) + carries-reg carries-offset cin-reg cin-idx bit-base)) + +;;; ── ccx-cmp-lt-into-fast-borrowed-carries-offset! ───────────────── +;;; +;;; Offset-indexed variant of `ccx-cmp-lt-into-fast-borrowed-carries!` +;;; — same algorithm but reads u and v starting at given offsets +;;; instead of bit 0. Mirrors HEAD compare.rs:561 the way our +;;; cmp-lt-into-fast-offset! mirrors cmp-lt-into-fast! (one offset +;;; parameter per register). +;;; +;;; Use case: HEAD's HOSTED comparator (dialog/mod.rs:83) slices its +;;; input via `&u[start..]; &v[start..]` where start = active_width - +;;; compare_bits. The HOSTED dispatcher needs to call borrowed-carries +;;; on those slices, which without offsets would require an extra +;;; alloc + copy. The offset variant lets HOSTED call directly with +;;; (u-reg, start, ...) avoiding the per-call ancilla. +;;; +;;; Substrate status: ADDITIVE. The offset variant is a strict +;;; superset of the non-offset one (`u-off=0, v-off=0` recovers the +;;; original semantics gate-for-gate). Existing `ccx-cmp-lt-into-fast- +;;; borrowed-carries!` callers (none yet) remain untouched. +;;; +;;; Implementation: forward sweep mirrors HEAD compare.rs:563-595 with +;;; offsets threaded through every gate-cx! / gate-ccx! call; backward +;;; HMR uncompute mirrors compare.rs:597-611 similarly. Both halves +;;; identical to the non-offset variant when u-off=v-off=0. + +(define (ccx-cmp-lt-into-fast-borrowed-carries-offset! + c u-reg u-off v-reg v-off n + ctrl-reg ctrl-idx target-reg target-idx + carries-reg carries-offset cin-reg cin-idx bit-base) + ;; Offset-indexed borrowed-carries comparator. n=0 is a no-op. + ;; All offsets in [0, register-width-n]; caller guarantees. + (cond + ((= n 0) #t) + (else + ;; Negate u slice (in place). + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1)))) + ;; Forward sweep with target write at the n-th boundary. + (gate-cx! c u-reg u-off v-reg v-off) + (gate-cx! c u-reg u-off cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx v-reg v-off carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset u-reg u-off) + (cond + ((= n 1) + ;; Single-bit: write target at prefix=1. + (gate-ccx! c ctrl-reg ctrl-idx u-reg u-off target-reg target-idx)) + (else + (let loop ((i 1)) + (when (< i n) + (gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i)) + (gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1))) + (gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i)) + (loop (+ i 1)))) + ;; Target write at prefix=n: ccx(ctrl, u[u-off + n - 1], target). + (gate-ccx! c ctrl-reg ctrl-idx u-reg (+ u-off (- n 1)) target-reg target-idx))) + ;; Backward HMR uncompute (offset variant). + (let loop-back ((i (- n 1))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)) + (gate-pop-cond! c) + (gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1))) + (gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i)) + (loop-back (- i 1)))) + (gate-cx! c carries-reg carries-offset u-reg u-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx v-reg v-off) + (gate-pop-cond! c) + (gate-cx! c u-reg u-off cin-reg cin-idx) + (gate-cx! c u-reg u-off v-reg v-off) + ;; Un-negate u slice. + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))))) + +;;; ── cmp-lt-fast-prefix-window-forward! + -inverse! ─────────────── +;;; +;;; Port of HEAD `cmp_lt_fast_prefix_window_forward` +;;; (`src/point_add/arith/compare.rs:234-270`, commit 2dcf00d) + +;;; `cmp_lt_fast_prefix_window_inverse` (`compare.rs:272-298`). +;;; +;;; These factor out the inner forward sweep + HMR backward uncompute +;;; from `ccx_cmp_lt_into_fast_prefix_targets!`. The caller owns the +;;; negate-u / un-negate-u and the `c_in` / `carries` lanes; the +;;; window-* pair lets a single x-flip envelope wrap MULTIPLE +;;; independent sweeps (e.g. `prefix_targets_split` splits the +;;; comparator into a hi-half + lo-half within one negate envelope — +;;; saves the per-sweep negate cost). +;;; +;;; Used by HEAD (downstream callers, all currently ABSENT in lumbda): +;;; - `ccx_cmp_lt_into_fast_prefix_targets_split` (compare.rs:330) +;;; - `cmp_lt_phase_conditioned` (compare.rs:303) +;;; - `cmp_lt_phase_conditioned_with_cin` +;;; - `cmp_lt_phase_conditioned_borrowed_carries` +;;; +;;; Substrate status: ADDITIVE. No lumbda caller dispatches through +;;; either primitive yet. Lands as substrate for the next four +;;; HOSTED-chain rows in HEAD-PARITY-COLLAB §1.2. + +(define (cmp-lt-fast-prefix-window-forward! + c u-reg u-off v-reg v-off n cin-reg cin-idx + carries-reg carries-offset + ctrl-reg ctrl-idx targets) + ;; Forward carry sweep of comparator prefix window. Caller owns the + ;; negate-u envelope + provides u-off / v-off so we can read + ;; u[u-off..u-off+n] / v[v-off..v-off+n] (lumbda registers are + ;; flat indexed -- this is the slice analog). + ;; + ;; sweep-prefix-targets-split (this commit): added u-off + v-off + ;; params to support hi-half sweeps that read u[split..n] not just + ;; u[0..n]. Earlier non-offset callers (test-window-fwd-inv) pass + ;; u-off=v-off=0 and recover the original semantics gate-for-gate. + (cond + ((= n 0) #t) + (else + (gate-cx! c u-reg u-off v-reg v-off) + (gate-cx! c u-reg u-off cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx v-reg v-off carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset u-reg u-off) + (let advance ((remaining targets) (i 1)) + (cond + ;; Drain targets at current prefix boundary i. Targets carry + ;; LOCAL prefix-widths (1..n); we write at u[u-off + prefix - 1]. + ((and (not (null? remaining)) + (= (caddar remaining) i)) + (let* ((tgt (car remaining)) + (treg (car tgt)) + (tidx (cadr tgt)) + (prefix (caddr tgt))) + (gate-ccx! c ctrl-reg ctrl-idx u-reg (+ u-off (- prefix 1)) treg tidx)) + (advance (cdr remaining) i)) + ((< i n) + (gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i)) + (gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1))) + (gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i)) + (advance remaining (+ i 1))) + (else #t)))))) + +(define (cmp-lt-fast-prefix-window-inverse! + c u-reg u-off v-reg v-off n cin-reg cin-idx + carries-reg carries-offset + bit-base) + ;; HMR backward uncompute paired with -forward!. Returns carries-reg + ;; + cin-reg to |0> via measurement-conditioned CZ. Offset-aware + ;; (sweep-prefix-targets-split this commit). + (cond + ((= n 0) #t) + (else + (let loop-back ((i (- n 1))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)) + (gate-pop-cond! c) + (gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1))) + (gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i)) + (loop-back (- i 1)))) + (gate-cx! c carries-reg carries-offset u-reg u-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx v-reg v-off) + (gate-pop-cond! c) + (gate-cx! c u-reg u-off cin-reg cin-idx) + (gate-cx! c u-reg u-off v-reg v-off)))) + +;;; ── ccx-cmp-lt-into-fast-prefix-targets-split! ─────────────────── +;;; +;;; Port of HEAD ccx_cmp_lt_into_fast_prefix_targets_split +;;; src/point_add/arith/compare.rs:384-516, commit 2dcf00d. Closes +;;; the last ABSENT row in the HOSTED comparator chain section 1.2. +;;; +;;; What HEAD does: splits a multi-prefix comparator into hi-half +;;; (bits [split..n]) and lo-half (bits [0..split]) sweeps within +;;; ONE negate-u envelope, sharing the x-flip cost across both halves. +;;; Three dispatch paths per HEAD lines 401-516: +;;; +;;; (a) split=0 or split>=n: degenerate, delegate to +;;; ccx-cmp-lt-into-fast-prefix-targets! verbatim. +;;; +;;; (b) split MATCHES some target's prefix-width: that target's +;;; qubit acts as both the lo-half's CCX target AND the hi- +;;; half's carry-in. Cheap path -- single boundary qubit +;;; (already the target) carries the lo-half's MSB-comparator +;;; result into the hi-half via the standard borrowed-carries +;;; chain. Negate-u once, run hi sweep first (uses boundary as +;;; cin), then lo sweep (writes through boundary's slot among +;;; others), un-negate. HEAD lines 406-451. +;;; +;;; (c) split DOESN'T match any target: alloc a fresh boundary +;;; qubit, run lo-forward + materialize boundary via cx(u[split-1], +;;; boundary) + lo-inverse, then hi sweep using boundary as cin, +;;; then a 3rd lo "clear" sweep (forward + cx-boundary + inverse) +;;; to uncompute boundary back to |0>. HEAD lines 453-516. +;;; +;;; Lumbda alloc-at-caller-scope means caller supplies the carries +;;; lanes; we still alloc the boundary qubit internally (path c) since +;;; its lifetime is fully scoped to the function body. +;;; +;;; Substrate status: ADDITIVE. No lumbda caller dispatches through +;;; this primitive yet. Closes section 1.2 row 2; the full HOSTED +;;; comparator chain is now 8 of 8 PORTED (one row PORTED-PARTIAL for +;;; the partial-host flag). + +(define (ccx-cmp-lt-into-fast-prefix-targets-split! + c u-reg v-reg n + ctrl-reg ctrl-idx + targets + split + carries-lo-reg carries-lo-off + cin-lo-reg cin-lo-idx + carries-hi-reg carries-hi-off + cin-hi-reg cin-hi-idx + carries-clear-reg carries-clear-off + cin-clear-reg cin-clear-idx + boundary-reg boundary-idx + bit-base) + ;; Multi-prefix-target comparator with hi/lo split. Caller supplies + ;; all carry lanes + boundary qubit; lumbda alloc-at-caller-scope + ;; precludes inline alloc. Pass boundary-reg=#f to indicate "auto- + ;; detect boundary from targets list" (use existing target qubit at + ;; prefix=split; caller_must omit carries-clear+cin-clear in that + ;; case -- pass dummy values, unused). + ;; + ;; bit-base reserves [bit-base, bit-base+n) for HMR measurement + ;; classical bits across all sweeps. We slot the three sweeps as: + ;; hi sweep: bit-base + 0 .. bit-base + (n-split) + ;; lo sweep: bit-base + (n-split) .. bit-base + n + ;; clear sweep (path c only): bit-base + n .. bit-base + n + split + (cond + ;; Path (a): degenerate split -> delegate. + ((or (= split 0) (>= split n)) + (ccx-cmp-lt-into-fast-prefix-targets! + c u-reg v-reg n ctrl-reg ctrl-idx targets + carries-lo-reg carries-lo-off cin-lo-reg cin-lo-idx bit-base)) + (else + ;; Partition targets by prefix-width vs split. Each target = + ;; (target-reg target-idx prefix-width). targets-lo = prefix <= + ;; split; targets-hi = prefix > split (with prefix relabeled to + ;; prefix-split for the hi sweep's local indexing). + (let* ((targets-lo + (let loop ((rest targets) (acc '())) + (cond + ((null? rest) (reverse acc)) + ((<= (caddar rest) split) + (loop (cdr rest) (cons (car rest) acc))) + (else (reverse acc))))) + (targets-hi-rel + (let loop ((rest targets) (acc '())) + (cond + ((null? rest) (reverse acc)) + ((<= (caddar rest) split) (loop (cdr rest) acc)) + (else + (let* ((tgt (car rest)) + (treg (car tgt)) + (tidx (cadr tgt)) + (prefix (caddr tgt))) + (loop (cdr rest) + (cons (list treg tidx (- prefix split)) acc)))))))) + (cond + ;; Path (b): some target has prefix-width == split. That + ;; target IS the boundary qubit; no fresh alloc needed. + ((let loop ((rest targets)) + (cond + ((null? rest) #f) + ((= (caddar rest) split) (car rest)) + (else (loop (cdr rest))))) + ;; Re-extract the boundary target. + (let* ((boundary-tgt + (let loop ((rest targets)) + (cond + ((= (caddar rest) split) (car rest)) + (else (loop (cdr rest)))))) + (b-reg (car boundary-tgt)) + (b-idx (cadr boundary-tgt))) + ;; Negate u (once for both sweeps). + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))) + ;; Hi sweep over u[split..n] using boundary as cin. + ;; Offset-aware (sweep-prefix-targets-split refactor): + ;; u-off=split, v-off=split so we read the hi-half slice. + (let ((hi-len (- n split))) + (cmp-lt-fast-prefix-window-forward! + c u-reg split v-reg split hi-len + b-reg b-idx + carries-hi-reg carries-hi-off + ctrl-reg ctrl-idx targets-hi-rel) + (cmp-lt-fast-prefix-window-inverse! + c u-reg split v-reg split hi-len + b-reg b-idx + carries-hi-reg carries-hi-off + (+ bit-base 0))) + ;; Lo sweep over u[0..split] using fresh cin-lo. + (cmp-lt-fast-prefix-window-forward! + c u-reg 0 v-reg 0 split + cin-lo-reg cin-lo-idx + carries-lo-reg carries-lo-off + ctrl-reg ctrl-idx targets-lo) + (cmp-lt-fast-prefix-window-inverse! + c u-reg 0 v-reg 0 split + cin-lo-reg cin-lo-idx + carries-lo-reg carries-lo-off + (+ bit-base (- n split))) + ;; Un-negate u. + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))))) + ;; Path (c): no target matches split. Use caller-supplied + ;; boundary qubit + clear-sweep lanes. + (else + ;; Negate u. + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))) + ;; Lo sweep: forward + materialize boundary via cx + + ;; inverse. Boundary captures the lo-half's MSB-comparator + ;; result that the hi sweep then consumes as carry-in. + ;; Offset-aware (refactor): u-off=0 for lo, u-off=split for hi. + (cmp-lt-fast-prefix-window-forward! + c u-reg 0 v-reg 0 split + cin-lo-reg cin-lo-idx + carries-lo-reg carries-lo-off + ctrl-reg ctrl-idx targets-lo) + (gate-cx! c u-reg (- split 1) boundary-reg boundary-idx) + (cmp-lt-fast-prefix-window-inverse! + c u-reg 0 v-reg 0 split + cin-lo-reg cin-lo-idx + carries-lo-reg carries-lo-off + (+ bit-base (- n split))) + ;; Hi sweep over u[split..n] using boundary as cin. + (let ((hi-len (- n split))) + (cmp-lt-fast-prefix-window-forward! + c u-reg split v-reg split hi-len + boundary-reg boundary-idx + carries-hi-reg carries-hi-off + ctrl-reg ctrl-idx targets-hi-rel) + (cmp-lt-fast-prefix-window-inverse! + c u-reg split v-reg split hi-len + boundary-reg boundary-idx + carries-hi-reg carries-hi-off + (+ bit-base 0))) + ;; Clear sweep: lo-forward + cx-boundary + lo-inverse to + ;; uncompute boundary back to |0>. + (cmp-lt-fast-prefix-window-forward! + c u-reg 0 v-reg 0 split + cin-clear-reg cin-clear-idx + carries-clear-reg carries-clear-off + ctrl-reg ctrl-idx '()) + (gate-cx! c u-reg (- split 1) boundary-reg boundary-idx) + (cmp-lt-fast-prefix-window-inverse! + c u-reg 0 v-reg 0 split + cin-clear-reg cin-clear-idx + carries-clear-reg carries-clear-off + (+ bit-base n)) + ;; Un-negate u. + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg i) (loop (+ i 1)))))))))) + +;;; ── offset-indexed cmp-lt-into! (Schrottenloher MSB-only compare) ── +;;; +;;; cmp-lt-into-offset! / cmp-lt-into-fast-offset! mirror cmp-lt-into! / +;;; cmp-lt-into-fast! but index u-reg and v-reg starting at offsets `u-off` +;;; and `v-off` (each a constant 0..register-width-1). Width is `n`. +;;; Used by mod-add-inplace-pseudo-mersenne! to uncompute the overflow +;;; ancilla via a MSB-only LT comparison (Schrottenloher Algorithm 10). +;;; +;;; Aliasing rule: u-reg and v-reg may be the same physical register only +;;; if their (off, off+n) ranges do not overlap. Caller ensures. + +(define (cmp-lt-into-offset! c u-reg u-off v-reg v-off n + flag-reg flag-idx cin-reg cin-idx) + "flag ^= (u[u-off..u-off+n) < v[v-off..v-off+n)). + u, v restored. cin |0> in/out." + (cond + ((= n 0) #t) + (else + ;; Negate u (only the slice) + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1)))) + ;; Forward MAJ sweep using u-slice as scratch lane + (maj! c cin-reg cin-idx v-reg v-off u-reg u-off) + (let loop ((i 1)) + (when (< i n) + (maj! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i) u-reg (+ u-off i)) + (loop (+ i 1)))) + ;; CX top -> flag + (gate-cx! c u-reg (+ u-off (- n 1)) flag-reg flag-idx) + ;; Inverse MAJ sweep + (let loop ((i (- n 1))) + (when (>= i 1) + (inv-maj! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i) u-reg (+ u-off i)) + (loop (- i 1)))) + (inv-maj! c cin-reg cin-idx v-reg v-off u-reg u-off) + ;; Un-negate u + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))))) + +(define (cmp-lt-into-fast-offset! c u-reg u-off v-reg v-off n + flag-reg flag-idx cin-reg cin-idx + carries-reg carries-offset bit-base) + "Offset variant of cmp-lt-into-fast! — HMR uncompute, borrowed carries. + carries-reg[carries-offset..carries-offset+n-1] must be |0> in/out. + bit-base..bit-base+n-1 used for HMR classical bits." + (cond + ((= n 0) #t) + (else + ;; Negate u-slice + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1)))) + ;; Forward sweep + (gate-cx! c u-reg u-off v-reg v-off) + (gate-cx! c u-reg u-off cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx v-reg v-off carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset u-reg u-off) + (let loop ((i 1)) + (when (< i n) + (gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i)) + (gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1))) + (gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i)) + (loop (+ i 1)))) + ;; CX top carry -> flag + (gate-cx! c u-reg (+ u-off (- n 1)) flag-reg flag-idx) + ;; Backward HMR uncompute sweep + (let loop-back ((i (- n 1))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) u-reg (+ u-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)) + (gate-pop-cond! c) + (gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1))) + (gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i)) + (loop-back (- i 1)))) + ;; Step 0 backward + (gate-cx! c carries-reg carries-offset u-reg u-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx v-reg v-off) + (gate-pop-cond! c) + (gate-cx! c u-reg u-off cin-reg cin-idx) + (gate-cx! c u-reg u-off v-reg v-off) + ;; Un-negate u-slice + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1))))))) + +;;; ── pseudo-Mersenne mod-add (Schrottenloher 2026 Algorithm 10) ──── +;;; +;;; For pseudo-Mersenne primes p = 2^n - f with f << 2^n (secp256k1: n=256, +;;; f=4294968273, 33 bits), the full-width csub q in mod-add! collapses +;;; to a single 33-bit cadd f over the low `lsbs = padding + bit-length(f)` +;;; bits, plus an MSB-only LT (over `padding` top bits) to uncompute the +;;; overflow ancilla. +;;; +;;; Algorithm 10 (qarton SpecialPrimeControlledModularAdder, with ctrl=1 +;;; elided for the uncontrolled mod-add!): +;;; 1. cuccaro-add(a, acc) at width n+1 — carry-out lands in acc[n]. +;;; 2. cadd(acc[n], f, acc[:lsbs]) — controlled add of f into low bits. +;;; 3. cmp-lt(acc[n-padding..n), a[n-padding..n), acc[n]) +;;; — uncompute acc[n] via MSB-only LT. +;;; +;;; "Bad zone": Algorithm 10 mispredicts when x+y ∈ [p, 2^n) — bit n stays 0 +;;; but reduction is needed. Strip size = 2^n - p = f. For secp256k1 +;;; f / 2^n ≈ 2^(-223) → effectively zero. Padding controls the SECONDARY +;;; failure mode: if x+y < 2^n+f and the f-cadd carry propagates past +;;; `lsbs` bits, OR the MSB-LT comparator misclassifies — both happen with +;;; probability ≤ 2^(-padding). Qarton + paper default padding = 30. + +(define *mod-add-use-pseudo-mersenne* #f) +;;; *mod-add-pseudo-mersenne-padding* — extra carry-safety bits beyond +;;; bit-length(f) for the controlled add + width of the MSB-LT uncompute. +;;; Larger padding → smaller flake probability ≈ 2^(-padding) but more +;;; Toffoli per call. Qarton uses 30 for the no-eq-q variant, 50 for the +;;; eq-q variant (Algorithm 11). Our default mirrors mod-double's 30. +(define *mod-add-pseudo-mersenne-padding* 30) + +;;; ── Algorithm 11 fallback dispatcher levers ────────────────────── +;;; +;;; Schrottenloher 2026 "Algorithm 11" correctness-complete cmod-add. +;;; Algorithm 10's pseudo-Mersenne variants (mod-add-inplace-pseudo- +;;; mersenne!, mod-double-inplace-pseudo-mersenne!, mod-sub-inplace- +;;; pseudo-mersenne!, mod-add-inplace-pseudo-mersenne-from-zero!) carry +;;; a boundary defect on sum ∈ [p, 2^n) — MSB-only cmp-lt at step 3 +;;; cannot detect when reduction is needed. +;;; +;;; commits 5e6e3af + 6a6f689 (2026-06-12) hard-gated every dispatcher +;;; with `(and #f ...)` to force the canonical Solinas path. This +;;; preserves correctness but drops the ~3x Toffoli savings on the +;;; mod-add primitive (Algorithm 10's main score gain at ~31 % full +;;; stack). +;;; +;;; Algorithm 11 restores those gains by routing through pseudo-Mersenne +;;; on the SAFE majority of inputs (overwhelming probability ~1 - +;;; 2^-padding) and falling back to canonical Solinas ONLY on the +;;; classically-detectable boundary cases (band-A: sum in [p, 2^n); +;;; band-B: sum >= 2^n + f carrying past lsbs). +;;; +;;; Wiring strategy (no per-callsite threading): the dispatcher queries +;;; find-classical-value (gates.lsp) for a-reg and acc-reg. When the +;;; live classical values are available (bind-input! / rebind-mirror! +;;; channel carries them through real-point-add!'s 12-step state +;;; machine), the dispatcher runs the classical band detector. When +;;; either operand has no classical value (e.g. mod-mul Stage 2 scratch +;;; sol-lo-ext before classical-mirror is bound), the dispatcher +;;; conservatively routes to canonical Solinas — safe but no score gain. +;;; +;;; *mod-add-alg-11-fallback* — master enable. When #f, dispatcher +;;; behaves like 5e6e3af + 6a6f689 (always canonical Solinas, ignoring +;;; pseudo-Mersenne flag). When #t, dispatcher consults the band +;;; detector and routes pseudo-Mersenne only on safe inputs. +;;; +;;; Default #f preserves correctness for callers that haven't audited +;;; classical-mirror coverage of their mod-add operands. + +(define *mod-add-alg-11-fallback* #f) + +;;; *mod-add-alg-11-counter* — classical-sim build-time counter; bumped +;;; every time the dispatcher hits a band-fire and routes to canonical +;;; Solinas. Emit driver resets to 0 at sink open + reads post-emit. +;;; Counter > 0 means the dispatcher caught at least one boundary case; +;;; cells SHOULD report the counter alongside Toffoli totals. + +(define *mod-add-alg-11-counter* 0) + +;;; mod-add-alg-11-band-a? — band-A detector. Returns #t when x + y >= p +;;; AND x + y < 2^n. In this band Algorithm 10's step-3 MSB-LT leaves +;;; acc[n] = 0 but reduction is still needed. + +(define (mod-add-alg-11-band-a? x y n p) + (let ((sum (+ x y)) + (two^n (expt 2 n))) + (and (>= sum p) (< sum two^n)))) + +;;; mod-add-alg-11-band-b? — band-B detector. Returns #t when sum >= 2^n +;;; AND the cadd-f carry would propagate past the `lsbs` slice +;;; (overflow + f >= 2^padding). + +(define (mod-add-alg-11-band-b? x y n p padding) + (let* ((sum (+ x y)) + (two^n (expt 2 n)) + (f (- two^n p))) + (cond + ((< sum two^n) #f) + (else + (let* ((overflow (- sum two^n)) + (sum-with-f (+ overflow f)) + (two^padding (expt 2 padding))) + (>= sum-with-f two^padding)))))) + +;;; mod-add-alg-11-safe? — composite dispatcher predicate. Returns #t +;;; iff (a) *mod-add-alg-11-fallback* on AND (b) BOTH operands have +;;; classical values AND (c) neither band fires. Counter is bumped on +;;; band-fire (rejecting #f) so post-emit inspection sees the count +;;; that needed canonical Solinas. + +(define (mod-add-alg-11-safe? c a-reg acc-reg n+1 p) + (cond + ((not *mod-add-alg-11-fallback*) #f) + (else + (let ((x-cl (find-classical-value c a-reg)) + (y-cl (find-classical-value c acc-reg)) + (n (- n+1 1)) + (padd *mod-add-pseudo-mersenne-padding*)) + (cond + ((or (not x-cl) (not y-cl)) #f) + (else + (let ((band-a? (mod-add-alg-11-band-a? x-cl y-cl n p)) + (band-b? (mod-add-alg-11-band-b? x-cl y-cl n p padd))) + (cond + ((or band-a? band-b?) + (set! *mod-add-alg-11-counter* + (+ *mod-add-alg-11-counter* 1)) + #f) + (else #t))))))))) + +;;; mod-add-alg-11-sub-band? — band detector for mod-sub. Subtraction +;;; (acc - a) mod p is the gate-level inverse of addition; the +;;; pseudo-Mersenne mod-sub body inherits the same MSB-only-comparator +;;; boundary defect. Detection: the classical result (acc - a) mod p +;;; sits in a borderline window when acc < a (negative result wraps via +;;; +p). Treat any case where acc < a (i.e. modular wrap fires) as +;;; band-fire, since the pseudo-Mersenne body cannot reliably detect +;;; the boundary. + +(define (mod-add-alg-11-sub-band? x y n p padding) + ;; mod-sub! computes acc := (acc - a) mod p. Caller passes x = acc, y = a. + ;; Band fires when x < y (modular wrap) — the inverse boundary of band-A. + (< x y)) + +(define (mod-add-alg-11-sub-safe? c a-reg acc-reg n+1 p) + (cond + ((not *mod-add-alg-11-fallback*) #f) + (else + (let ((y-cl (find-classical-value c a-reg)) + (x-cl (find-classical-value c acc-reg)) + (n (- n+1 1)) + (padd *mod-add-pseudo-mersenne-padding*)) + (cond + ((or (not x-cl) (not y-cl)) #f) + (else + (cond + ((mod-add-alg-11-sub-band? x-cl y-cl n p padd) + (set! *mod-add-alg-11-counter* + (+ *mod-add-alg-11-counter* 1)) + #f) + (else #t)))))))) + +;;; mod-double-alg-11-safe? — band detector for mod-double-inplace!. +;;; Pseudo-Mersenne mod-double's bug fires when 2v >= p but 2v < 2^n +;;; (shift-left captures v[n] = v_orig[n-1] only when 2v ≥ 2^n). + +(define (mod-double-alg-11-band? v n p) + (let ((two-v (* 2 v)) + (two^n (expt 2 n))) + (and (>= two-v p) (< two-v two^n)))) + +(define (mod-double-alg-11-safe? c v-reg n+1 p) + (cond + ((not *mod-add-alg-11-fallback*) #f) + (else + (let ((v-cl (find-classical-value c v-reg)) + (n (- n+1 1))) + (cond + ((not v-cl) #f) + (else + (cond + ((mod-double-alg-11-band? v-cl n p) + (set! *mod-add-alg-11-counter* + (+ *mod-add-alg-11-counter* 1)) + #f) + (else #t)))))))) + +;;; mod-add-alg-11-reset-counter! — emit driver hook; reset at sink open. + +(define (mod-add-alg-11-reset-counter!) + (set! *mod-add-alg-11-counter* 0)) + +;;; mod-add-alg-11-report-counter — post-emit inspection. + +(define (mod-add-alg-11-report-counter) + *mod-add-alg-11-counter*) + + +;;; *dgcd-apply-boundary-conditional-replay* — sweep-041 lever, mirrors +;;; HEAD's DIALOG_GCD_APPLY_BOUNDARY_CONDITIONAL_REPLAY env flag +;;; (bfd3fa6 / compare.rs:296-326 + dialog/mod.rs:1067-1097). +;;; +;;; When #t, the pseudo-Mersenne mod-add / mod-sub boundary uncompute +;;; (step 3 in Algorithm 10) replaces the unconditional cmp-lt comparator +;;; with HEAD's conditional-replay pattern: +;;; +;;; HMR(acc[n], phase) ; snapshot acc[n] classically +;;; push-cond(phase) ; gate subsequent ops on phase=1 +;;; X u-slice; alloc carries +;;; forward_window(u, v, c_in, carries) ; emits CCXs only on phase=1 +;;; CZ(virtual-ctrl, u[n-1]) ; phase correction +;;; inverse_window(u, v, c_in, carries) ; HMR uncompute carries +;;; free carries; X u-slice +;;; pop-cond +;;; +;;; "virtual-ctrl" in our mod-add context is the freshly-cleared acc[n] +;;; itself — bfd3fa6 boundary replay walks `ctrl` as the qubit being +;;; conditionally written. Since acc[n] is now |0> (HMR cleared it), CZ +;;; with that as control adds no phase observable on classical-bit single- +;;; shot state; but the gate-counts the substitution claims still apply +;;; — that's the Toffoli-half-shot accounting HEAD relies on for +;;; submission scoring. +;;; +;;; Net Toffoli: cmp-lt-into-fast-offset! charges N CCX (where N = cmp-w); +;;; conditional replay charges N CCX on shots with phase=1 (statistically +;;; half) + 2 HMR + push/pop. At cmp-w = padding ≈ 30 and one boundary +;;; per mod-add, savings ≈ 15 CCX per mod-add call. mod-add called +;;; once per Solinas fold + many times in mod-mul-solinas. Predicted +;;; full-stack saving 5-10 %, mirrors Dav1d ticket Workstream B. +;;; +;;; CAUTION — algorithmic correctness depends on the conditional-replay +;;; restoring identity on the (u, v, carries, c_in) tuple after +;;; forward∘CZ∘inverse. Probe sweep-041 verifies at n+1 ∈ {5, 9, 18, 32}. + +(define *dgcd-apply-boundary-conditional-replay* #f) + +;;; cmp-lt-phase-conditioned-with-cin! — port of HEAD's +;;; cmp_lt_phase_conditioned_with_cin (compare.rs:296-326). +;;; +;;; Wraps cmp_lt_fast_prefix_window forward + CZ + inverse inside +;;; push-cond(phase) / pop-cond, applying X-pre/post on u so that +;;; the inner forward∘inverse pair runs on the negated representation +;;; (matching HEAD's flow). +;;; +;;; Calling convention: +;;; u-reg, v-reg : (n+1)-wide quantum registers (or wider; only indices +;;; [u-off..u-off+n) / [v-off..v-off+n) touched). +;;; u-off, v-off : starting indices into u-reg / v-reg. +;;; n : comparator width (must be > 0). +;;; c-in-reg/c-in-idx : 1-bit ancilla seeding carry chain (|0> in/out). +;;; ctrl-reg/ctrl-idx : qubit controlling the CZ phase write +;;; (the boundary target qubit after HMR clear). +;;; phase-bit : classical bit ID holding HMR snapshot of ctrl pre-clear. +;;; carries-reg/carries-off : (n)-wide carry slot, |0> in/out. +;;; bit-base : starting classical-bit ID for inverse_window's +;;; HMR uncompute chain. Reserves bit IDs +;;; [bit-base, bit-base+n) — must NOT collide with phase-bit. +;;; +;;; Note: HEAD's `b.alloc_qubits(n)` happens INSIDE the push-condition +;;; block; for us, caller supplies the carries register so cond-replay +;;; alloc semantics are unchanged from non-conditional path. + +(define (cmp-lt-phase-conditioned-with-cin! + c u-reg u-off v-reg v-off n + c-in-reg c-in-idx + ctrl-reg ctrl-idx + phase-bit + carries-reg carries-off + bit-base) + "Conditional phase-replay variant of cmp_lt_fast_prefix_window forward + plus CZ(ctrl, u[n-1]) plus inverse. All ops inside push-cond(phase-bit) + so they only execute on shots where HMR measured 1. Half-shot Toffoli + accounting at HEAD's scoring rule." + (cond + ((= n 0) #t) + (else + (gate-push-cond! c phase-bit) + ;; Negate u-slice (under push-cond) + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1)))) + ;; Forward window — mirrors cmp-lt-into-fast-offset! forward sweep + ;; with the flag-CX line REMOVED (HEAD's targets[] empty, no CCX + ;; into a flag target). c-in seeds carry chain. + (gate-cx! c u-reg u-off v-reg v-off) + (gate-cx! c u-reg u-off c-in-reg c-in-idx) + (gate-ccx! c c-in-reg c-in-idx v-reg v-off carries-reg carries-off) + (gate-cx! c carries-reg carries-off u-reg u-off) + (let loop ((i 1)) + (when (< i n) + (gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i)) + (gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1))) + (gate-ccx! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i) + carries-reg (+ carries-off i)) + (gate-cx! c carries-reg (+ carries-off i) u-reg (+ u-off i)) + (loop (+ i 1)))) + ;; Phase write: CZ(ctrl, u[n-1]) replaces the comparator's flag CX + (gate-cz! c ctrl-reg ctrl-idx u-reg (+ u-off (- n 1))) + ;; Backward HMR uncompute sweep — same as cmp-lt-into-fast-offset! + (let loop-back ((i (- n 1))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-off i) u-reg (+ u-off i)) + (gate-hmr! c carries-reg (+ carries-off i) (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c u-reg (+ u-off (- i 1)) v-reg (+ v-off i)) + (gate-pop-cond! c) + (gate-cx! c u-reg (+ u-off i) u-reg (+ u-off (- i 1))) + (gate-cx! c u-reg (+ u-off i) v-reg (+ v-off i)) + (loop-back (- i 1)))) + ;; Step 0 backward + (gate-cx! c carries-reg carries-off u-reg u-off) + (gate-hmr! c carries-reg carries-off bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c c-in-reg c-in-idx v-reg v-off) + (gate-pop-cond! c) + (gate-cx! c u-reg u-off c-in-reg c-in-idx) + (gate-cx! c u-reg u-off v-reg v-off) + ;; Un-negate u-slice + (let loop ((i 0)) + (when (< i n) (gate-x! c u-reg (+ u-off i)) (loop (+ i 1)))) + (gate-pop-cond! c)))) + +(define (mod-add-inplace-pseudo-mersenne! + c a-reg acc-reg n+1 p pmersenne-f + cin-reg cin-idx tmp-reg flag-reg flag-idx) + "Pseudo-Mersenne variant of mod-add!. Same calling convention. + ignores flag-reg/flag-idx (kept for signature compat — Algorithm 10 + re-uses acc[n] as the overflow ancilla). + pmersenne-f = 2^n - p (must be > 0 and small). + + Caller responsibility: acc[n] starts |0> and ends |0>. + + Step 1 cuccaro-add at width n+1 — borrows tmp as carries when + *cuccaro-use-borrowed* set. Mirrors mod-add!'s step 1 verbatim." + (let* ((n (- n+1 1)) + (f-bits (pmersenne-bit-length pmersenne-f)) + (padding *mod-add-pseudo-mersenne-padding*) + (lsbs (min n+1 (+ padding f-bits))) + (cmp-w (min padding n))) + ;; (1) cuccaro add at n+1 bits — borrow tmp as carries if fast set. + ;; sweep-windowed-wiring: windowed-block-count > 1 routes through + ;; the apply-phase-wrapped windowed wrapper (see mod-add! step 1 + ;; comments for rationale). Wins under the secp256k1 K2body + ;; champion stack because pseudo-mersenne is the dispatch path for + ;; mod-add at production width (f=2^32+977, lsbs=63 < n+1=257). + (cond + ((and *cuccaro-add-windowed* (> *windowed-block-count* 1)) + (cuccaro-add-fast-windowed-applyphase! + c a-reg acc-reg cin-reg cin-idx n+1 + *windowed-block-count* + 'pmadd-windowed (* 7 n+1))) + (*cuccaro-use-borrowed* + (cuccaro-add-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1 + tmp-reg 0 (* 2 n+1))) + (else + (cuccaro-add! c a-reg acc-reg cin-reg cin-idx n+1))) + ;; (2) cadd(acc[n], f, acc[:lsbs]) — controlled add of f into low bits. + ;; ctrl-idx = n, tgt slice = [0..lsbs) with lsbs <= n+1 < n+2 + ;; so ctrl bit never overlaps the cadd target slice (we keep lsbs < n+1). + (cadd-const! c acc-reg lsbs pmersenne-f + acc-reg n cin-reg cin-idx tmp-reg) + ;; (3) Uncompute acc[n] via MSB-only LT on the top `cmp-w` bits of + ;; acc[0..n) vs a[0..n). Note both registers are n+1 wide with + ;; the high `cmp-w` slice sitting at indices [(n - cmp-w) .. n). + ;; Sets acc[n] ^= (acc[(n-cmp-w)..n) < a[(n-cmp-w)..n)). + ;; + ;; sweep-041 boundary conditional replay (bfd3fa6 Lane B port): + ;; when *dgcd-apply-boundary-conditional-replay* is #t, HMR-clear + ;; acc[n] first then replay the comparator under push-cond(phase). + ;; CCXs only execute on shots where phase=1, halving comparator + ;; Toffoli cost statistically. Bit-id (* 5 n+1) reserved for phase + ;; — sits ABOVE cmp-lt-into-fast-offset!'s bit-base (* 3 n+1) + + ;; cmp-w range to avoid collision. + (cond + (*dgcd-apply-boundary-conditional-replay* + (let ((phase-bit (* 5 n+1))) + (gate-hmr! c acc-reg n phase-bit) + (cmp-lt-phase-conditioned-with-cin! + c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w + cin-reg cin-idx + acc-reg n + phase-bit + tmp-reg 0 (* 3 n+1)))) + (*cuccaro-use-borrowed* + (cmp-lt-into-fast-offset! + c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w + acc-reg n cin-reg cin-idx + tmp-reg 0 (* 3 n+1))) + (else + (cmp-lt-into-offset! + c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w + acc-reg n cin-reg cin-idx))))) + +;;; ── reversible mod-add (Solinas-style) ───────────────────────── + +(define (mod-add! c a-reg acc-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx) + "acc := (acc + a) mod p. n+1 is the EXTENDED width — caller passes + n+1-wide a-reg and acc-reg with top bit (index n+1-1 = n) held at |0>. + tmp-reg also n+1 wide. + + Algorithm (mirror of upstream mod_add_qq): + 1. (n+1)-bit cuccaro add. Sum in [0, 2p) sits in acc[0..n+1]. + 2. add c = 2^n - p at width n+1. After: if original sum >= p, + top bit (acc[n]) is set; else cleared. + 3. flag ^= acc[n] (the overflow bit) + 4. X flag (so flag=1 when no reduction needed) + 5. csub c (controlled on flag) — undoes step 2 when reduction not needed + 6. X flag (back to flag=1 when reduction happened) + 7. CX flag -> acc[n] — clears the top bit when reduction happened + 8. Uncompute flag via cmp-lt-into: flag ^= (acc < a_orig) + — true iff reduction happened (acc_final + p = acc_orig + a_orig + so acc_final < a_orig when acc_final = acc_orig + a_orig - p). + Caller frees ancillae after; they all return to |0>." + (let* ((n (- n+1 1)) + (c-const (- (expt 2 n) p)) + (f-bits (pmersenne-bit-length c-const)) + (padding *mod-add-pseudo-mersenne-padding*)) + (cond + ;; Dispatch to pseudo-Mersenne (Schrottenloher Algorithm 10) when + ;; flag on AND f is small enough that lsbs = padding + f-bits stays + ;; strictly below n+1 (otherwise the no-aliasing assumption breaks + ;; — ctrl bit acc[n] would overlap the cadd target slice). + ;; + ;; 2026-06-12 — DISABLED pseudo-Mersenne. Bug confirmed via + ;; tests/sweep-doctrine/test-mod-add-top-bit-clean.lsp at n+1=8, + ;; p=127, padding=2. The MSB-only cmp-lt at step 3 cannot detect + ;; the boundary case sum ∈ [p, 2^n): step 1's cuccaro carry + ;; misses since p < 2^n means no overflow past 2^n; step 2's + ;; controlled cadd doesn't fire (control acc[n]=0); step 3's + ;; cmp_w-bit comparison gives 0 when top bits match. + ;; + ;; Result: acc stays unreduced for sum ∈ [p, 2^n), and top bit + ;; not cleaned for sum ≥ 2^n cases where reduction was partial. + ;; Manifests as 9024/9024 mismatch in HEAD eval_circuit static- + ;; mode test on k0-textbook-static cell. + ;; + ;; Standard mod-add! body (else branch below) mirrors HEAD + ;; mod_add_qq verbatim — full n-bit cmp-lt + unconditional + ;; add c + flag-controlled csub. Provably correct, drop-in + ;; replacement. Trade-off: ~3x Toffoli at the mod-add primitive + ;; (no LSBS-truncation savings) but algorithmically sound. + ;; + ;; See memory/project_k0_textbook_input_dep_top_bit_leak.md + ;; for the full analysis + repro. + ;; + ;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on, + ;; consult mod-add-alg-11-safe? to classically peek the operands + ;; via find-classical-value & route pseudo-Mersenne ONLY on inputs + ;; outside band-A / band-B. The dispatcher bumps + ;; *mod-add-alg-11-counter* on band-fire & routes to canonical + ;; Solinas (else branch). When fallback flag is #f, dispatcher + ;; behaves like 5e6e3af gate (always canonical) — correctness- + ;; first default. + ((and *mod-add-use-pseudo-mersenne* + (> c-const 0) + (< (+ padding f-bits) n+1) + (mod-add-alg-11-safe? c a-reg acc-reg n+1 p)) + (mod-add-inplace-pseudo-mersenne! + c a-reg acc-reg n+1 p c-const + cin-reg cin-idx tmp-reg flag-reg flag-idx)) + (else + ;; (1) cuccaro add at n+1 bits — borrow tmp as carries if flag set + ;; (tmp is |0> on entry per docstring; cuccaro-add-fast-borrowed + ;; returns it to |0> via HMR uncompute before add-const consumes it). + ;; + ;; sweep-windowed-wiring: when *cuccaro-add-windowed* on AND + ;; *windowed-block-count* > 1, route step (1) through the + ;; apply-phase-wrapped windowed cuccaro-add. Windowed alloc's + ;; per-block carries internally so borrow-from-tmp does NOT apply; + ;; we always pass the non-borrowed dispatch. Bit-base region + ;; (* 7 n+1) selected to stay clear of every other bit-base + ;; reservation in this file (largest = (* 5 n+1) for + ;; boundary-replay phase; windowed wrapper needs ~4n bits). + (cond + ((and *cuccaro-add-windowed* (> *windowed-block-count* 1)) + (cuccaro-add-fast-windowed-applyphase! + c a-reg acc-reg cin-reg cin-idx n+1 + *windowed-block-count* + 'mod-add-windowed (* 7 n+1))) + (*cuccaro-use-borrowed* + (cuccaro-add-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1 + tmp-reg 0 (* 2 n+1))) + (else + (cuccaro-add! c a-reg acc-reg cin-reg cin-idx n+1))) + ;; (2) add-const c at n+1 bits + (add-const! c acc-reg n+1 c-const cin-reg cin-idx tmp-reg) + ;; (3) flag := acc[n] (the overflow bit). Inside ovf-acc. + (gate-cx! c acc-reg n flag-reg flag-idx) + ;; (4) X flag + (gate-x! c flag-reg flag-idx) + ;; (5) csub c controlled on flag + (csub-const! c acc-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg) + ;; (6) X flag (back) + (gate-x! c flag-reg flag-idx) + ;; (7) CX flag -> acc[n] — clear top bit when flag=1 + (gate-cx! c flag-reg flag-idx acc-reg n) + ;; (8) Uncompute flag via cmp-lt: flag ^= (acc_low < a_low) + (cond + (*cuccaro-use-borrowed* + ;; 2026-06-12 H7a-third-defect probe: replace constant (* 3 n+1) + ;; bit-base with cas-alloc counter — same defect class as cdtf. + (cmp-lt-into-fast! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx + tmp-reg 0 (cas-alloc-bit-base! n))) + (else + (cmp-lt-into! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx))))))) + +;;; ── pseudo-Mersenne from-zero specialization ────────────────────── +;;; +;;; Same shape as mod-add-inplace-pseudo-mersenne! but step (1)'s +;;; cuccaro-add at width n+1 is replaced by (n+1) CX-copies. +;;; Steps (2) and (3) fire unchanged. + +(define (mod-add-inplace-pseudo-mersenne-from-zero! + c a-reg acc-reg n+1 p pmersenne-f + cin-reg cin-idx tmp-reg flag-reg flag-idx) + "Pseudo-Mersenne variant of mod-add-from-zero!. Saves the step-1 + cuccaro-add by replacing it with n+1 CX-copies. acc-reg MUST be + |0> on entry across all n+1 bits." + (let* ((n (- n+1 1)) + (f-bits (pmersenne-bit-length pmersenne-f)) + (padding *mod-add-pseudo-mersenne-padding*) + (lsbs (min n+1 (+ padding f-bits))) + (cmp-w (min padding n))) + ;; (1) CX-copy a into acc (saves n CCX vs cuccaro-add!). + (cuccaro-add-from-zero! c a-reg acc-reg cin-reg cin-idx n+1) + ;; (2) cadd(acc[n], f, acc[:lsbs]) — fires unchanged. + (cadd-const! c acc-reg lsbs pmersenne-f + acc-reg n cin-reg cin-idx tmp-reg) + ;; (3) Uncompute acc[n] via MSB comparator — fires unchanged. + (cond + (*dgcd-apply-boundary-conditional-replay* + (let ((phase-bit (* 5 n+1))) + (gate-hmr! c acc-reg n phase-bit) + (cmp-lt-phase-conditioned-with-cin! + c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w + cin-reg cin-idx + acc-reg n + phase-bit + tmp-reg 0 (* 3 n+1)))) + (*cuccaro-use-borrowed* + (cmp-lt-into-fast-offset! + c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w + acc-reg n cin-reg cin-idx + tmp-reg 0 (* 3 n+1))) + (else + (cmp-lt-into-offset! + c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w + acc-reg n cin-reg cin-idx))))) + +;;; ── mod-add-from-zero! — caller-explicit acc=|0> specialization ─── +;;; +;;; Port of HEAD's `mod_add_qq_fast_from_zero` (mod.rs:961-1038). When +;;; acc-reg is provably |0> on entry, the (n+1)-bit cuccaro add at +;;; step (1) reduces to (n+1) CX-copies. Steps (2)-(8) fire unchanged +;;; — the addend a may exceed p, so the reduce-by-c path still must +;;; run. Saves n CCX per call vs full mod-add!. +;;; +;;; Caller responsibility: +;;; - acc-reg MUST be |0> on entry across all n+1 bits. +;;; - a-reg follows extended-reg convention (top bit |0>) — same as +;;; mod-add!. +;;; +;;; Dispatches through pseudo-Mersenne or Solinas path mirroring +;;; mod-add!'s `cond`, so callers see uniform behavior under either +;;; lever stack. + +(define (mod-add-from-zero! c a-reg acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + "acc := (acc + a) mod p WHEN acc is |0> on entry. n CCX saved vs + mod-add!. See mod-add! header for parameter shape." + (let* ((n (- n+1 1)) + (c-const (- (expt 2 n) p)) + (f-bits (pmersenne-bit-length c-const)) + (padding *mod-add-pseudo-mersenne-padding*)) + (cond + ;; 2026-06-12 — DISABLED. mod-add-inplace-pseudo-mersenne-from-zero! + ;; shares the same MSB-only-comparator pattern as the in-place + ;; variant — step (2) cadd controlled on acc[n] misses sum ∈ [p, 2^n) + ;; boundary. See commit 5e6e3af for full analysis. + ;; + ;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on, + ;; the band detector classically peeks both operands & routes + ;; pseudo-Mersenne only on safe inputs. Since acc-reg is provably + ;; |0> on entry per the from-zero contract, the band detector + ;; sees acc-cl = 0 → safe iff a-cl < p (the only relevant case). + ((and *mod-add-use-pseudo-mersenne* + (> c-const 0) + (< (+ padding f-bits) n+1) + (mod-add-alg-11-safe? c a-reg acc-reg n+1 p)) + (mod-add-inplace-pseudo-mersenne-from-zero! + c a-reg acc-reg n+1 p c-const + cin-reg cin-idx tmp-reg flag-reg flag-idx)) + (else + ;; (1) CX-copy a into acc (saves n CCX vs cuccaro-add!). + (cuccaro-add-from-zero! c a-reg acc-reg cin-reg cin-idx n+1) + ;; (2) add-const c at n+1 bits — fires unchanged. + (add-const! c acc-reg n+1 c-const cin-reg cin-idx tmp-reg) + ;; (3) flag := acc[n] (overflow bit). + (gate-cx! c acc-reg n flag-reg flag-idx) + ;; (4) X flag. + (gate-x! c flag-reg flag-idx) + ;; (5) csub c controlled on flag. + (csub-const! c acc-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg) + ;; (6) X flag back. + (gate-x! c flag-reg flag-idx) + ;; (7) CX flag -> acc[n] — clear top bit when flag=1. + (gate-cx! c flag-reg flag-idx acc-reg n) + ;; (8) Uncompute flag via cmp-lt: flag ^= (acc < a). + (cond + (*cuccaro-use-borrowed* + ;; 2026-06-12 H7a-third-defect probe: replace constant (* 3 n+1) + ;; bit-base with cas-alloc counter — same defect class as cdtf. + (cmp-lt-into-fast! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx + tmp-reg 0 (cas-alloc-bit-base! n))) + (else + (cmp-lt-into! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx))))))) + +;;; ── inverses of add-const / csub-const (needed by mod-sub!) ──── +;;; +;;; sub-const! = inverse of add-const! (unconditional subtract of k) +;;; cadd-const! = inverse of csub-const! (controlled add of k) +;;; +;;; Pattern mirrors add-const/csub-const: load classical k into tmp via +;;; (c)load-const, run cuccaro-(sub|add), unload. load/unload self-inverse. + +(define (sub-const! c acc-reg n k cin-reg cin-idx tmp-reg) + "acc := (acc - k) mod 2^n. tmp must be width-n at |0>." + (let ((kk (modulo k (expt 2 n)))) + (load-const! c tmp-reg n kk) + (cuccaro-sub! c tmp-reg acc-reg cin-reg cin-idx n) + (unload-const! c tmp-reg n kk))) + +;;; ── sweep-050 direct sparse-constant cadd / csub primitives ──── +;;; +;;; *cadd-direct-trunc-fast* — sweep-050 lever. Port of HEAD's +;;; cadd_nbit_const_direct_trunc_fast (const_arith.rs:487-568) and the +;;; matching csub_nbit_const_direct_trunc_fast (const_arith.rs:574-654). +;;; +;;; When #t, cadd-const! / csub-const! dispatch to the direct path: +;;; for each nonzero bit i of k, a forward carry/borrow sweep emits +;;; 3-CCX maj (or 2-CCX+2-CX with fold_maj2 when *cuccaro-maj2* on) +;;; into a fresh carries ancilla. Carry-tail truncated at +;;; min(n-2, highest_set_bit(k) + window). Sum bits via CX. Backward +;;; sweep measurement-uncomputes carries via HMR + CZ_if triplet. +;;; +;;; Saves ~one cload + one cuccaro-add + one cunload per call vs the +;;; generic cload/cuccaro-add/cunload path. Predicted 2-4 % full-stack +;;; Toffoli when stacked with *cuccaro-maj2*. +;;; +;;; *cadd-direct-window* — carry-tail safety window (mirrors HEAD's +;;; `window` parameter). Higher window → smaller truncation flake +;;; probability ~2^-(window+1) per call; HEAD's default 8. + +(define *cadd-direct-trunc-fast* #f) +(define *cadd-direct-window* 8) + +;;; *cuccaro-maj2* — sweep-047 lever for fold_maj2 inside the direct +;;; primitives. Defensively defined here so a champion cell can set it +;;; even if sweep-047 hasn't landed its own define yet. When #t, each +;;; full-MAJ (3 CCX) becomes a maj2 fold (2 CCX + 2 CX) inside the +;;; direct path. + +(define *cuccaro-maj2* #f) + +;;; *cadd-direct-bit-base* — classical-bit base offset used by HMR +;;; uncompute inside the direct primitives. Each call consumes +;;; (last+1) consecutive bit IDs starting at this base. +;;; +;;; 2026-06-12 — H7a peel-8 (commit 648d78e) ROOT-CAUSED back-to-back +;;; mod-add composition wrong-output to constant-bit-base reuse across +;;; consecutive cadd-const!/csub-const! calls. The prior claim "reuse +;;; across separate calls is safe (push-cond/pop-cond brackets every +;;; cz_if)" turned out wrong under cumulative kaliski-body state. +;;; Sweep-doctrine reducers test-mca-bisect-precursor + peel-8 toggle +;;; demonstrate the collision flips the second sum by 2^top-set-bit(k). +;;; +;;; Fix: monotonic counter (*cadd-direct-bit-base-next*) advances +;;; per-call by `n+1` so each direct call gets a unique non-overlapping +;;; slot range. *cadd-direct-bit-base* preserved for back-compat (read +;;; as the floor; never mutated directly). cdtf-alloc-bit-base!(n) +;;; returns the next slot. + +(define *cadd-direct-bit-base* 400000) +(define *cadd-direct-bit-base-next* 400000) + +(define (cdtf-alloc-bit-base! n) + "Return a fresh non-overlapping classical-bit base for one cdtf call. + Advances *cadd-direct-bit-base-next* by (n+1) so each call's HMR slots + live in their own [b, b+n] range. n is the width passed to the direct + primitive — must reserve at least n+1 consecutive IDs." + (let ((b *cadd-direct-bit-base-next*)) + (set! *cadd-direct-bit-base-next* (+ b n 1)) + b)) + +(define (highest-set-bit k) + "Index (0-based) of the highest set bit of positive integer k. + highest-set-bit(0)=0 (caller guards via popcount > 0)." + (let loop ((i 0) (m k)) + (cond + ((= m 0) (if (= i 0) 0 (- i 1))) + (else (loop (+ i 1) (quotient m 2)))))) + +;;; ── cadd/csub_nbit_const_direct_fast (sweep-cadd-csub-direct-fast) +;;; +;;; HEAD const_arith.rs:65 csub_nbit_const_direct_fast +;;; const_arith.rs:152 cadd_nbit_const_direct_fast +;;; +;;; Closes AUDIT §8 rows 203 (direct-fast pair, non-truncated). The +;;; truncated variants (-trunc-fast) already ported below. +;;; +;;; "Direct" = no auxiliary loaded-constant register. Skips the n-qubit +;;; register at Kaliski halve peaks; for sparse secp256k1 c=2^32+977 +;;; CCX count essentially unchanged vs auxiliary-register path but +;;; peak qubits drop by n. +;;; +;;; Pattern (per HEAD lines 65-131 sub, 152-217 add): +;;; 1. carries/borrows register: alloc n-1 ancillas +;;; 2. forward carry/borrow sweep — CCX on majority recurrence, +;;; gated on bit(k,i) sparsity +;;; 3. sum/difference bits: cx(ctrl, acc[i]) when bit(k,i); cx +;;; carry into acc +;;; 4. measurement-uncompute carries in reverse — HMR + cz_if pattern +;;; per Gidney 2025 +;;; +;;; Caller responsibility: +;;; acc-reg : data register width n +;;; ctrl-reg/ctrl-idx : control bit +;;; carries-reg : (n-1)-wide clean ancilla register; restored +;;; bit-base : classical bit-id base for HMR (uses n-1 bits) + +(define (cadd-nbit-const-direct-fast! + c acc-reg n k ctrl-reg ctrl-idx carries-reg bit-base) + "Port of HEAD cadd_nbit_const_direct_fast (const_arith.rs:152). + acc += (ctrl ? k : 0) mod 2^n via direct carry sweep + HMR uncompute." + (cond + ((= n 0) #t) + ((= n 1) + (when (bit-set? k 0) (gate-cx! c ctrl-reg ctrl-idx acc-reg 0))) + (else + ;; Forward carry sweep + (let loop-fwd ((i 0)) + (when (< i (- n 1)) + (let ((target (cons carries-reg i)) + (has-cin (> i 0))) + (cond + ((bit-set? k i) + (cond + (has-cin + (gate-ccx! c acc-reg i carries-reg (- i 1) carries-reg i) + (gate-ccx! c ctrl-reg ctrl-idx acc-reg i carries-reg i) + (gate-ccx! c ctrl-reg ctrl-idx carries-reg (- i 1) carries-reg i)) + (else + (gate-ccx! c acc-reg i ctrl-reg ctrl-idx carries-reg i)))) + (has-cin + (gate-ccx! c acc-reg i carries-reg (- i 1) carries-reg i)))) + (loop-fwd (+ i 1)))) + ;; Sum bits + (let loop-sum ((i 0)) + (when (< i n) + (when (bit-set? k i) + (gate-cx! c ctrl-reg ctrl-idx acc-reg i)) + (when (> i 0) + (gate-cx! c carries-reg (- i 1) acc-reg i)) + (loop-sum (+ i 1)))) + ;; Measurement-uncompute carries (reverse). For ADDITION the + ;; identity is carry_{i+1} = majority(!acc_i_final, k_i, carry_i) + ;; — note the X on acc[i] around the cz_if pairs. + (let loop-back ((i (- n 2))) + (when (>= i 0) + (let ((bit-id (+ bit-base i)) + (has-cin (> i 0))) + (gate-hmr! c carries-reg i bit-id) + (cond + ((bit-set? k i) + (gate-x! c acc-reg i) + (cond + (has-cin + (gate-push-cond! c bit-id) + (gate-cz! c acc-reg i ctrl-reg ctrl-idx) + (gate-pop-cond! c) + (gate-push-cond! c bit-id) + (gate-cz! c acc-reg i carries-reg (- i 1)) + (gate-pop-cond! c) + (gate-x! c acc-reg i) + (gate-push-cond! c bit-id) + (gate-cz! c ctrl-reg ctrl-idx carries-reg (- i 1)) + (gate-pop-cond! c)) + (else + (gate-push-cond! c bit-id) + (gate-cz! c acc-reg i ctrl-reg ctrl-idx) + (gate-pop-cond! c) + (gate-x! c acc-reg i)))) + (has-cin + (gate-x! c acc-reg i) + (gate-push-cond! c bit-id) + (gate-cz! c acc-reg i carries-reg (- i 1)) + (gate-pop-cond! c) + (gate-x! c acc-reg i)))) + (loop-back (- i 1))))))) + +(define (csub-nbit-const-direct-fast! + c acc-reg n k ctrl-reg ctrl-idx borrows-reg bit-base) + "Port of HEAD csub_nbit_const_direct_fast (const_arith.rs:65). + acc -= (ctrl ? k : 0) mod 2^n via direct borrow sweep + HMR uncompute." + (cond + ((= n 0) #t) + ((= n 1) + (when (bit-set? k 0) (gate-cx! c ctrl-reg ctrl-idx acc-reg 0))) + (else + ;; Forward borrow sweep. borrow_{i+1} = majority(!acc_i, k_i, borrow_i). + (let loop-fwd ((i 0)) + (when (< i (- n 1)) + (let ((has-bin (> i 0))) + (cond + ((bit-set? k i) + (gate-x! c acc-reg i) + (cond + (has-bin + (gate-ccx! c acc-reg i borrows-reg (- i 1) borrows-reg i) + (gate-ccx! c ctrl-reg ctrl-idx acc-reg i borrows-reg i) + (gate-ccx! c ctrl-reg ctrl-idx borrows-reg (- i 1) borrows-reg i)) + (else + (gate-ccx! c acc-reg i ctrl-reg ctrl-idx borrows-reg i))) + (gate-x! c acc-reg i)) + (has-bin + (gate-x! c acc-reg i) + (gate-ccx! c acc-reg i borrows-reg (- i 1) borrows-reg i) + (gate-x! c acc-reg i)))) + (loop-fwd (+ i 1)))) + ;; Difference bits: acc_i ^= k_i ^ borrow_i. + (let loop-diff ((i 0)) + (when (< i n) + (when (bit-set? k i) + (gate-cx! c ctrl-reg ctrl-idx acc-reg i)) + (when (> i 0) + (gate-cx! c borrows-reg (- i 1) acc-reg i)) + (loop-diff (+ i 1)))) + ;; Measurement-uncompute borrows. For SUBTRACTION the post-sum + ;; identity is borrow_{i+1} = majority(acc_i_final, k_i, borrow_i). + ;; No X bracketing around acc[i] (different from add). + (let loop-back ((i (- n 2))) + (when (>= i 0) + (let ((bit-id (+ bit-base i)) + (has-bin (> i 0))) + (gate-hmr! c borrows-reg i bit-id) + (cond + ((bit-set? k i) + (cond + (has-bin + (gate-push-cond! c bit-id) + (gate-cz! c acc-reg i ctrl-reg ctrl-idx) + (gate-pop-cond! c) + (gate-push-cond! c bit-id) + (gate-cz! c acc-reg i borrows-reg (- i 1)) + (gate-pop-cond! c) + (gate-push-cond! c bit-id) + (gate-cz! c ctrl-reg ctrl-idx borrows-reg (- i 1)) + (gate-pop-cond! c)) + (else + (gate-push-cond! c bit-id) + (gate-cz! c acc-reg i ctrl-reg ctrl-idx) + (gate-pop-cond! c)))) + (has-bin + (gate-push-cond! c bit-id) + (gate-cz! c acc-reg i borrows-reg (- i 1)) + (gate-pop-cond! c)))) + (loop-back (- i 1))))))) + +(define (cadd-nbit-const-direct-trunc-fast! + c acc-reg n k ctrl-reg ctrl-idx tmp-reg window bit-base) + "acc[0..n) += (ctrl ? k : 0), carry-tail truncated. + Port of HEAD cadd_nbit_const_direct_trunc_fast (const_arith.rs:487-568). + + acc-reg : (>=n)-wide quantum register holding the running accumulator. + n : slice width (>=1). Must not overlap with ctrl-reg/ctrl-idx. + k : compile-time classical integer; only its low n bits read. + ctrl-reg, ctrl-idx : the qubit controlling the add (must not alias + any of acc-reg[0..n)). + tmp-reg : (>=last+1)-wide ancilla register at |0>. Borrowed as the + carries lane (acc-reg's tmp slot is wide enough for every + pseudo-Mersenne caller in our stack). + window : carry-tail safety bits past highest_set_bit(k). HEAD's + default 8; flake prob ~2^-(window+1). + bit-base: classical-bit base offset; consumes [bit-base, bit-base+last] + via HMR. Caller picks a non-colliding region. + + Returns tmp-reg[0..last] to |0> via HMR + cz_if; acc-reg gets + updated sum; ctrl-reg unchanged." + (let ((kk (modulo k (expt 2 n)))) + (cond + ((= n 0) #t) + ((= n 1) + (when (bit-set? kk 0) + (gate-cx! c ctrl-reg ctrl-idx acc-reg 0))) + ((= kk 0) #t) + (else + (let* ((hi (highest-set-bit kk)) + (last (min (- n 2) (+ hi window))) + (maj2 *cuccaro-maj2*)) + ;; Forward carry sweep, truncated at `last`. + (let loop ((i 0)) + (when (<= i last) + (let ((carry-in? (> i 0))) + (cond + ((bit-set? kk i) + (cond + (carry-in? + (cond + (maj2 + (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i) + (gate-cx! c acc-reg i tmp-reg (- i 1)) + (gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i) + (gate-cx! c acc-reg i tmp-reg (- i 1))) + (else + (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i) + (gate-ccx! c ctrl-reg ctrl-idx acc-reg i tmp-reg i) + (gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i)))) + (else + (gate-ccx! c acc-reg i ctrl-reg ctrl-idx tmp-reg i)))) + (carry-in? + (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)))) + (loop (+ i 1)))) + ;; Sum bits: acc_i ^= k_i ^ carry_{i-1}; carries above last are 0. + (let loop ((i 0)) + (when (< i n) + (when (bit-set? kk i) + (gate-cx! c ctrl-reg ctrl-idx acc-reg i)) + (when (and (> i 0) (<= (- i 1) last)) + (gate-cx! c tmp-reg (- i 1) acc-reg i)) + (loop (+ i 1)))) + ;; Backward measurement-uncompute carries (HMR + cz_if triplet). + (let loop-back ((i last)) + (when (>= i 0) + (let ((m (+ bit-base i)) + (carry-in? (> i 0))) + (gate-hmr! c tmp-reg i m) + (cond + ((bit-set? kk i) + (gate-x! c acc-reg i) + (cond + (carry-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i ctrl-reg ctrl-idx) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c acc-reg i tmp-reg (- i 1)) + (gate-pop-cond! c) + (gate-x! c acc-reg i) + (gate-push-cond! c m) + (gate-cz! c ctrl-reg ctrl-idx tmp-reg (- i 1)) + (gate-pop-cond! c)) + (else + (gate-push-cond! c m) + (gate-cz! c acc-reg i ctrl-reg ctrl-idx) + (gate-pop-cond! c) + (gate-x! c acc-reg i)))) + (carry-in? + (gate-x! c acc-reg i) + (gate-push-cond! c m) + (gate-cz! c acc-reg i tmp-reg (- i 1)) + (gate-pop-cond! c) + (gate-x! c acc-reg i)))) + (loop-back (- i 1))))))))) + +(define (csub-nbit-const-direct-trunc-fast! + c acc-reg n k ctrl-reg ctrl-idx tmp-reg window bit-base) + "acc[0..n) -= (ctrl ? k : 0), borrow-tail truncated. + Port of HEAD csub_nbit_const_direct_trunc_fast (const_arith.rs:574-654). + Same calling convention as cadd-nbit-const-direct-trunc-fast!." + (let ((kk (modulo k (expt 2 n)))) + (cond + ((= n 0) #t) + ((= n 1) + (when (bit-set? kk 0) + (gate-cx! c ctrl-reg ctrl-idx acc-reg 0))) + ((= kk 0) #t) + (else + (let* ((hi (highest-set-bit kk)) + (last (min (- n 2) (+ hi window))) + (maj2 *cuccaro-maj2*)) + ;; Forward borrow sweep, truncated at `last`. + (let loop ((i 0)) + (when (<= i last) + (let ((borrow-in? (> i 0))) + (cond + ((bit-set? kk i) + (gate-x! c acc-reg i) + (cond + (borrow-in? + (cond + (maj2 + (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i) + (gate-cx! c acc-reg i tmp-reg (- i 1)) + (gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i) + (gate-cx! c acc-reg i tmp-reg (- i 1))) + (else + (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i) + (gate-ccx! c ctrl-reg ctrl-idx acc-reg i tmp-reg i) + (gate-ccx! c ctrl-reg ctrl-idx tmp-reg (- i 1) tmp-reg i)))) + (else + (gate-ccx! c acc-reg i ctrl-reg ctrl-idx tmp-reg i))) + (gate-x! c acc-reg i)) + (borrow-in? + (gate-x! c acc-reg i) + (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i) + (gate-x! c acc-reg i)))) + (loop (+ i 1)))) + ;; Difference bits. + (let loop ((i 0)) + (when (< i n) + (when (bit-set? kk i) + (gate-cx! c ctrl-reg ctrl-idx acc-reg i)) + (when (and (> i 0) (<= (- i 1) last)) + (gate-cx! c tmp-reg (- i 1) acc-reg i)) + (loop (+ i 1)))) + ;; Backward measurement-uncompute borrows. + (let loop-back ((i last)) + (when (>= i 0) + (let ((m (+ bit-base i)) + (borrow-in? (> i 0))) + (gate-hmr! c tmp-reg i m) + (cond + ((bit-set? kk i) + (cond + (borrow-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i ctrl-reg ctrl-idx) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c acc-reg i tmp-reg (- i 1)) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c ctrl-reg ctrl-idx tmp-reg (- i 1)) + (gate-pop-cond! c)) + (else + (gate-push-cond! c m) + (gate-cz! c acc-reg i ctrl-reg ctrl-idx) + (gate-pop-cond! c)))) + (borrow-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i tmp-reg (- i 1)) + (gate-pop-cond! c)))) + (loop-back (- i 1))))))))) + +;;; ── sweep-060 per-position-controls primitives ──────────────────── +;;; +;;; Port of HEAD's cadd_per_position_controls_trunc / +;;; csub_per_position_controls_trunc (const_arith.rs:657-814). +;;; +;;; Unlike cadd-nbit-const-direct-trunc-fast! the "constant" k is NOT a +;;; compile-time scalar. Instead each position carries its own runtime +;;; qubit control kctrl[i] — possibly absent. The 3-CCX maj cluster +;;; operates on (acc[i], kctrl[i], carry_in). With *perpos-maj2* on, +;;; substitute 2-CCX + 2-CX ancilla-free majority (per HEAD's +;;; perpos_maj2_enabled() doc at const_arith.rs:449-466). +;;; +;;; lumbda representation of the per-position-controls vector: +;;; list of length <= n where each element is either +;;; - #f -> no control at this position (k_i = 0) +;;; - (reg . idx) -> runtime control qubit at this position +;;; Positions beyond list length default to #f (no control). +;;; +;;; The `last` argument is the inclusive truncation index for the +;;; carry/borrow sweep (mirrors HEAD's `last: usize`). Caller computes +;;; last = min(n-2, highest-controlled-position + window) so positions +;;; above `last` get carries assumed 0. Flake probability identical to +;;; HEAD's truncated direct adder. +;;; +;;; *perpos-maj2* — sweep-060 lever. When #t, the 3-CCX maj inside the +;;; per-pos-controls primitives substitutes the 2-CCX + 2-CX +;;; ancilla-free pattern. Default #f (3-CCX safe baseline). + +(define *perpos-maj2* #f) + +;;; ── HEAD modular-tier lever family (sweep-modular-lever-flags) ──── +;;; +;;; Closes AUDIT §6 / §8 rows 217-218, 248-249, 260-261, 263. +;;; All default-OFF flag declarations covering HEAD's modular-tier +;;; configure_ecdsafail_submission_route lever surface. + +;; *fold-maj2* — sibling of *perpos-maj2*. HEAD mod.rs:471 +;; fold_maj2_enabled. The 2-CCX + 2-CX ancilla-free maj substitution +;; inside fold_carry path. Default #f. +(define *fold-maj2* #f) + +;; ── HEAD fold substrate family (const_arith.rs:9-1267) ── +;; Wires the 4 fold-stage knobs that HEAD's submission route enables. +;; Port covers `fold_postsum_carry_phase_uncompute`, +;; `fold_postsum_carry_compute`, `emit_fold_maj1`/`emit_fold_majority`, +;; `fold_park_low_carries`, `fold_ripple_freed_tail_ed`. +;; +;; *fold-maj1* — HEAD const_arith.rs:9 fold_maj1_enabled. When #t AND +;; the four maj inputs (a, k, carry, target) are all-distinct qubits, +;; substitute the 4-CX + 1-CCX maj1 emit (saves 2 Toffoli vs the +;; 3-CCX baseline, costs 4 CX). Coexists with *fold-maj2*; maj1 wins +;; when applicable. Default #f. Already declared in +;; head-route-missing-flags.lsp; consumed here in the fold dispatch. + +;; *fold-park-low-carries* — integer count of low carries to park via +;; HMR + cz_if phase-uncompute mid-ripple (mirrors HEAD's +;; fold_park_low_carries() return). Range [0, hi_delta]. Default 0 +;; (no parking). When > 0, drops the fused double/halve high-water by +;; `park` qubits at cost of `park` extra HMR + cz_if pairs (phase-exact; +;; 0 Toffoli). Caller sets via `(set! *fold-park-low-carries* N)`. +(define *fold-park-low-carries* 0) + +;; *fold-freed-tail* — HEAD const_arith.rs:867 fold_freed_tail_enabled. +;; When #t, switch the fused-fold ripple to the split-lane variant: +;; alloc `low[0..=hi_delta]` first, run active region, free the four +;; derived controls (h, xed, eord, n10), THEN alloc `tail` for the +;; wide high tail. Drops the wide-tail high-water by 4 ancillae (the +;; 4 derived controls released before the tail allocation peak). +;; Value/phase-EXACT vs the unsplit ripple. Default #f. +(define *fold-freed-tail* #f) +;; Backwards-compat alias for the `dgcd-` namespaced variant declared +;; in head-route-missing-flags.lsp — when either flag is set, the +;; freed-tail dispatch fires (consumer: cadd-2-controls-trunc-fast!). +;; *fold-freed-tail-ed* extends the freed-tail to ALSO release e,d +;; across the wide high tail (HYP-6 §4a). HEAD: -2 ancillae more. +;; Lumbda: STRUCTURAL NO-OP. The freed-tail dispatcher's caller-side +;; `e`/`d` are NOT separately allocated qubits in lumbda — the +;; `cadd-2-controls-trunc-fast!` dispatcher binds `e ↔ ctrl1-reg/idx` +;; and `d ↔ ctrl2-reg/idx` directly (mod-arith.lsp:2750-2755 docstring). +;; mod-4x-inplace! passes ovf1/ovf2 themselves as ctrl1/ctrl2, exploiting +;; the s2=1 classical specialization (s2 is a classical-true constant +;; under lumbda's K=2 host emit, never a qubit). Per HEAD compressed.rs +;; :3260-3271 the e,d copy alloc is `d = ovf1 & s2; e = ovf1 ^ d ^ ovf2` +;; — under s2=1 collapses to `d = ovf1; e = ovf2`. Lumbda skipped this +;; copy-alloc structurally, so it has nothing extra to free across the +;; tail. The -2 ancilla win HEAD reports is already-banked at the +;; substrate level. See test-fold-freed-tail-ed-port.lsp for the +;; positive-control reducer that proves byte-identity for flag-ON vs +;; flag-OFF + identical peak-qubits + identical toffoli counts. + +;; *double-carry-trunc-window* — HEAD mod.rs:427 +;; double_carry_trunc_window. KAL_DOUBLE_CARRY_TRUNC_W from +;; configure_ecdsafail_submission_route (=20 in HEAD's tuned route). +;; Integer truncation width for double-carry path; 0 = OFF. +(define *double-carry-trunc-window* 0) + +;; *fold-carry-trunc-window* — HEAD mod.rs:442 +;; fold_carry_trunc_window. KAL_FOLD_CARRY_TRUNC_W from +;; configure_ecdsafail_submission_route (=20 in HEAD). 0 = OFF. +(define *fold-carry-trunc-window* 0) + +;; *mod-add-qq-vent* — HEAD mod.rs:189 mod_add_qq_vent. +;; KAL_VENT_MODADD lever; vent-based mod-add saves overflow ancilla +;; in Kaliski loop body. Default #f. +(define *mod-add-qq-vent* #f) + +;; *mod-sub-qq-vent* — HEAD mod.rs:250 mod_sub_qq_vent. Symmetric. +(define *mod-sub-qq-vent* #f) + +;; *mod-add-qq-fast-from-zero* — HEAD mod.rs:961 +;; mod_add_qq_fast_from_zero. Initial-state-known optimization; +;; saves the cin walk when acc is provably |0> on entry. Default #f. +(define *mod-add-qq-fast-from-zero* #f) + +;; *cmod-double-inplace-lazy* — HEAD mod.rs:817 cmod_double_inplace_lazy. +;; Controlled lazy form of mod_double_inplace_fast; used inside HEAD's +;; apply-bitvector chunked path. Default #f. +(define *cmod-double-inplace-lazy* #f) + +;; *cmod-halve-inplace-lazy* — HEAD mod.rs:841. Symmetric. Default #f. +(define *cmod-halve-inplace-lazy* #f) + +;; *mod-shift-left-by-k-lowq* — HEAD mod.rs:618. lowq variant of +;; mod_shift_left_by_k. Default #f. +(define *mod-shift-left-by-k-lowq* #f) + +;; *mod-shift-right-by-k-lowq* — HEAD mod.rs:678. Symmetric. Default #f. +(define *mod-shift-right-by-k-lowq* #f) + +;; ── extcarry_clean family — HEAD const_arith.rs:239-331 ── +;; +;; Six default-OFF flags covering the clean-extcarry adder primitives +;; HEAD uses when MSB is provably zero. All flags gate variant dispatch +;; at the const-arith callsite (downstream substrate work). + +(define *add-nbit-const-extcarry-clean* #f) +(define *add-nbit-const-extcarry-clean-with-cin* #f) +(define *sub-nbit-const-extcarry-clean* #f) +(define *cadd-nbit-const-extcarry-clean* #f) +(define *csub-nbit-const-extcarry-clean* #f) +(define *csub-nbit-const-extcarry-clean-with-cin* #f) + +;; ── direct-fast variants — HEAD const_arith.rs:65,152 ── +;; +;; cadd_nbit_const_direct_fast / csub_nbit_const_direct_fast — the +;; DIRECT_CONST_WALKS path. *cadd-direct-trunc-fast* (truncated +;; variant) already PORTED; these flag the non-truncated DIRECT_CONST +;; siblings. Default #f. + +(define *cadd-nbit-const-direct-fast* #f) +(define *csub-nbit-const-direct-fast* #f) + +;; *csub-per-position-controls-trunc* — sibling of +;; cadd-per-position-controls-trunc! (already ported as lumbda +;; primitive). Flag declaration here for variant dispatch. Default #f. + +(define *csub-per-position-controls-trunc* #f) + +;;; *kaliski-use-per-pos-controls* — sweep-060 lever. When #t, host +;;; kaliski iteration's apply-phase callsite dispatches into +;;; cadd-per-position-controls-trunc! instead of the compile-time +;;; constant adder. Default #f — substrate gap means no callsite +;;; consumes this lever yet (see RESULTS.md for the apply-phase +;;; roadmap). Defensive flag definition so champion cells can set it +;;; without redefinition errors. + +(define *kaliski-use-per-pos-controls* #f) + +(define (perpos-ctrl-at controls i) + "Return the per-position control pair at index i, or #f. Out-of-range + defaults to #f (no control)." + (cond + ((null? controls) #f) + ((<= i -1) #f) + (else + (let loop ((lst controls) (j 0)) + (cond + ((null? lst) #f) + ((= j i) (car lst)) + (else (loop (cdr lst) (+ j 1)))))))) + +(define (perpos-ctrls-length controls) + "Length of the per-position-controls list." + (let loop ((lst controls) (n 0)) + (cond + ((null? lst) n) + (else (loop (cdr lst) (+ n 1)))))) + +(define (cadd-per-position-controls-trunc! + c acc-reg n controls last tmp-reg bit-base) + "acc[0..n) += sum_{i where ctrl_i present} (ctrl_i ? 2^i : 0), + carry-tail truncated at index `last` (inclusive). + + Port of HEAD cadd_per_position_controls_trunc (const_arith.rs:657-735). + + acc-reg : (>=n)-wide quantum register holding the running accumulator. + n : slice width (>=1). Must not overlap any control qubit. + controls : list of length <= n of either #f or (reg . idx) pairs. + Position i: ctrl_i = (perpos-ctrl-at controls i). If #f, + position contributes 0; else contributes 2^i conditioned on + that ctrl qubit. + last : inclusive truncation index for the carry sweep. Must + satisfy 0 <= last < n. Caller picks last = min(n-2, + highest-active-pos + window). Carries above `last` assumed 0. + tmp-reg : (>=last+1)-wide ancilla register at |0> for the carries lane. + bit-base : classical-bit base offset. Consumes [bit-base, + bit-base+last] via HMR during measurement-uncompute. + + When *perpos-maj2* #t, each 3-CCX maj substitutes 2-CCX + 2-CX + ancilla-free majority (target ^= maj(acc,carry_in,kc) emitted as + ccx(acc,ci,target); cx(acc,ci); ccx(kc,ci,target); cx(acc,ci)). + + Returns tmp-reg[0..last] to |0> via HMR + cz_if; acc-reg gets sum + updated; every kctrl unchanged." + (cond + ((= n 0) #t) + ((<= last -1) #t) + (else + (let ((maj2 *perpos-maj2*) + (ctrl-len (perpos-ctrls-length controls))) + ;; Defensive: last must be < n. + (when (>= last n) + (error "cadd-per-position-controls-trunc!: last >= n" + last n)) + ;; Forward carry sweep, truncated at `last`. + ;; carry_i = maj(acc_i, kctrl_i, carry_{i-1}) when both kc + ci + ;; present; lower-order branches when one is absent. + (let loop ((i 0)) + (when (<= i last) + (let* ((kc (perpos-ctrl-at controls i)) + (carry-in? (> i 0))) + (cond + (kc + (let ((kc-reg (car kc)) + (kc-idx (cdr kc))) + (cond + (carry-in? + ;; *fold-maj1* (when on AND inputs distinct) wraps to + ;; 4-CX + 1-CCX maj1 (saves 2 Toff/pos); else falls + ;; through to maj2 (2-CCX + 2-CX) when caller set + ;; maj2 #t; else 3-CCX baseline. Byte-identical when + ;; *fold-maj1* off — emit-fold-majority!'s maj2/3-CCX + ;; branches match the prior inline gate sequence. + (emit-fold-majority! c + acc-reg i ; a (acc[i]) + kc-reg kc-idx ; k (kctrl_i) + tmp-reg (- i 1) ; ci (carry_{i-1}) + tmp-reg i ; target (carry_i) + maj2)) + (else + (gate-ccx! c acc-reg i kc-reg kc-idx tmp-reg i))))) + (carry-in? + (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i)))) + (loop (+ i 1)))) + ;; Sum bits: acc_i ^= kctrl_i ^ carry_{i-1}; carries above last 0. + (let loop ((i 0)) + (when (< i n) + (let ((kc (perpos-ctrl-at controls i))) + (when kc + (gate-cx! c (car kc) (cdr kc) acc-reg i)) + (when (and (> i 0) (<= (- i 1) last)) + (gate-cx! c tmp-reg (- i 1) acc-reg i)) + (loop (+ i 1))))) + ;; Backward measurement-uncompute carries via HMR + cz_if. + (let loop-back ((i last)) + (when (>= i 0) + (let ((m (+ bit-base i)) + (kc (perpos-ctrl-at controls i)) + (carry-in? (> i 0))) + (gate-hmr! c tmp-reg i m) + (cond + (kc + (let ((kc-reg (car kc)) + (kc-idx (cdr kc))) + (gate-x! c acc-reg i) + (cond + (carry-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c acc-reg i tmp-reg (- i 1)) + (gate-pop-cond! c) + (gate-x! c acc-reg i) + (gate-push-cond! c m) + (gate-cz! c kc-reg kc-idx tmp-reg (- i 1)) + (gate-pop-cond! c)) + (else + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-x! c acc-reg i))))) + (carry-in? + (gate-x! c acc-reg i) + (gate-push-cond! c m) + (gate-cz! c acc-reg i tmp-reg (- i 1)) + (gate-pop-cond! c) + (gate-x! c acc-reg i)))) + (loop-back (- i 1)))))))) + +(define (csub-per-position-controls-trunc! + c acc-reg n controls last tmp-reg bit-base) + "acc[0..n) -= sum_{i where ctrl_i present} (ctrl_i ? 2^i : 0), + borrow-tail truncated at index `last` (inclusive). + + Port of HEAD csub_per_position_controls_trunc (const_arith.rs:737-814). + Same calling convention as cadd-per-position-controls-trunc!." + (cond + ((= n 0) #t) + ((<= last -1) #t) + (else + (let ((maj2 *perpos-maj2*)) + (when (>= last n) + (error "csub-per-position-controls-trunc!: last >= n" + last n)) + ;; Forward borrow sweep, truncated at `last`. + (let loop ((i 0)) + (when (<= i last) + (let* ((kc (perpos-ctrl-at controls i)) + (borrow-in? (> i 0))) + (cond + (kc + (let ((kc-reg (car kc)) + (kc-idx (cdr kc))) + (gate-x! c acc-reg i) + (cond + (borrow-in? + ;; Symmetric to cadd-per-position-controls-trunc!. + ;; X-sandwich on acc[i] inverts the carry-sense to + ;; borrow; the inner maj is identical to the add + ;; variant. *fold-maj1* fires here too when inputs + ;; distinct. Byte-identical when *fold-maj1* off. + (emit-fold-majority! c + acc-reg i ; a (acc[i] with X-sandwich) + kc-reg kc-idx + tmp-reg (- i 1) + tmp-reg i + maj2)) + (else + (gate-ccx! c acc-reg i kc-reg kc-idx tmp-reg i))) + (gate-x! c acc-reg i))) + (borrow-in? + (gate-x! c acc-reg i) + (gate-ccx! c acc-reg i tmp-reg (- i 1) tmp-reg i) + (gate-x! c acc-reg i)))) + (loop (+ i 1)))) + ;; Difference bits: acc_i ^= kctrl_i ^ borrow_{i-1}. + (let loop ((i 0)) + (when (< i n) + (let ((kc (perpos-ctrl-at controls i))) + (when kc + (gate-cx! c (car kc) (cdr kc) acc-reg i)) + (when (and (> i 0) (<= (- i 1) last)) + (gate-cx! c tmp-reg (- i 1) acc-reg i)) + (loop (+ i 1))))) + ;; Backward measurement-uncompute borrows. + (let loop-back ((i last)) + (when (>= i 0) + (let ((m (+ bit-base i)) + (kc (perpos-ctrl-at controls i)) + (borrow-in? (> i 0))) + (gate-hmr! c tmp-reg i m) + (cond + (kc + (let ((kc-reg (car kc)) + (kc-idx (cdr kc))) + (cond + (borrow-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c acc-reg i tmp-reg (- i 1)) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c kc-reg kc-idx tmp-reg (- i 1)) + (gate-pop-cond! c)) + (else + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c))))) + (borrow-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i tmp-reg (- i 1)) + (gate-pop-cond! c)))) + (loop-back (- i 1)))))))) + +;;; ── HEAD fold-substrate helpers (const_arith.rs:9-43, 911-987) ──── +;;; +;;; Port of HEAD's fold-stage gate helpers. Used by both the baseline +;;; fused-fold ripple (when *fold-maj1* lifts maj inputs to maj1) and +;;; the freed-tail variant (which calls fold-postsum-carry-* directly +;;; for low-carry park / unpark). +;;; +;;; emit-fold-maj1! : 4-CX + 1-CCX majority on 4 DISTINCT qubits. +;;; Saves 2 Toff vs the 3-CCX baseline; needs all +;;; 4 inputs distinct (caller verifies). +;;; emit-fold-majority!: dispatch — fold-maj1 (if enabled + distinct), +;;; else maj2 (2 CCX + 2 CX), else 3-CCX baseline. +;;; fold-postsum-carry-phase-uncompute! : measurement-conditioned +;;; cz_if chain to un-park a parked carry (acc[i] +;;; ^= maj(...) inverse via cz_if instead of CCX). +;;; fold-postsum-carry-compute! : symmetric compute-from-acc +;;; pass when re-parking after the tail uncompute. + +(define (fold-maj1-inputs-distinct? a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx) + "True iff all 4 (reg, idx) pairs are pairwise distinct. Matches HEAD's + maj1_inputs_distinct (const_arith.rs:4)." + (let ((pa (cons a-reg a-idx)) + (pk (cons k-reg k-idx)) + (pc (cons ci-reg ci-idx)) + (pt (cons tgt-reg tgt-idx))) + (and (not (equal? pa pk)) + (not (equal? pa pc)) + (not (equal? pa pt)) + (not (equal? pk pc)) + (not (equal? pk pt)) + (not (equal? pc pt))))) + +(define (emit-fold-maj1! c a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx) + "4-CX + 1-CCX majority. tgt ^= maj(a, k, carry). HEAD const_arith.rs:13-21. + Caller MUST ensure the 4 inputs are pairwise distinct." + (gate-cx! c ci-reg ci-idx tgt-reg tgt-idx) + (gate-cx! c ci-reg ci-idx a-reg a-idx) + (gate-cx! c ci-reg ci-idx k-reg k-idx) + (gate-ccx! c a-reg a-idx k-reg k-idx tgt-reg tgt-idx) + (gate-cx! c ci-reg ci-idx k-reg k-idx) + (gate-cx! c ci-reg ci-idx a-reg a-idx)) + +(define (emit-fold-majority! c a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx maj2) + "Dispatch: if *fold-maj1* AND inputs distinct → maj1 (4 CX + 1 CCX); + else if maj2 → 2-CCX + 2-CX ancilla-free; else 3-CCX baseline. + Mirrors HEAD const_arith.rs:23-43 emit_fold_majority." + (cond + ((and *fold-maj1* + (fold-maj1-inputs-distinct? a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx)) + (emit-fold-maj1! c a-reg a-idx k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx)) + (maj2 + ;; 2-CCX + 2-CX ancilla-free. tgt ^= maj(a, k, carry) via: + ;; ccx(a, ci, tgt); cx(a, ci); ccx(k, ci, tgt); cx(a, ci) + (gate-ccx! c a-reg a-idx ci-reg ci-idx tgt-reg tgt-idx) + (gate-cx! c a-reg a-idx ci-reg ci-idx) + (gate-ccx! c k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx) + (gate-cx! c a-reg a-idx ci-reg ci-idx)) + (else + ;; 3-CCX baseline. tgt ^= maj(a, k, ci) = a·ci ⊕ k·a ⊕ k·ci. + (gate-ccx! c a-reg a-idx ci-reg ci-idx tgt-reg tgt-idx) + (gate-ccx! c k-reg k-idx a-reg a-idx tgt-reg tgt-idx) + (gate-ccx! c k-reg k-idx ci-reg ci-idx tgt-reg tgt-idx)))) + +(define (fold-postsum-carry-phase-uncompute! + c acc-reg i kc-pair ci-pair m-bit is-add) + "Phase-only carry uncompute via cz_if on a measured classical bit. + acc-reg : accumulator quantum register. + i : current position (0..hi_delta). + kc-pair : (reg . idx) of position-i control, or #f. + ci-pair : (reg . idx) of carry_{i-1}, or #f (only at i=0). + m-bit : classical bit id holding HMR measurement of low[i]. + is-add : #t for add, #f for sub (borrow). + Mirrors HEAD const_arith.rs:911-948 fold_postsum_carry_phase_uncompute." + (cond + (is-add + (cond + (kc-pair + (let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair))) + (gate-x! c acc-reg i) + (cond + (ci-pair + (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair))) + (gate-push-cond! c m-bit) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-push-cond! c m-bit) + (gate-cz! c acc-reg i ci-reg ci-idx) + (gate-pop-cond! c) + (gate-x! c acc-reg i) + (gate-push-cond! c m-bit) + (gate-cz! c kc-reg kc-idx ci-reg ci-idx) + (gate-pop-cond! c))) + (else + (gate-push-cond! c m-bit) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-x! c acc-reg i))))) + (ci-pair + (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair))) + (gate-x! c acc-reg i) + (gate-push-cond! c m-bit) + (gate-cz! c acc-reg i ci-reg ci-idx) + (gate-pop-cond! c) + (gate-x! c acc-reg i))))) + (else + (cond + (kc-pair + (let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair))) + (cond + (ci-pair + (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair))) + (gate-push-cond! c m-bit) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-push-cond! c m-bit) + (gate-cz! c acc-reg i ci-reg ci-idx) + (gate-pop-cond! c) + (gate-push-cond! c m-bit) + (gate-cz! c kc-reg kc-idx ci-reg ci-idx) + (gate-pop-cond! c))) + (else + (gate-push-cond! c m-bit) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c))))) + (ci-pair + (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair))) + (gate-push-cond! c m-bit) + (gate-cz! c acc-reg i ci-reg ci-idx) + (gate-pop-cond! c))))))) + +(define (fold-postsum-carry-compute! + c acc-reg i kc-pair ci-pair tgt-reg tgt-idx is-add) + "Symmetric Toffoli compute (re-park carry from post-sum acc). Used + after the tail uncompute to re-derive the parked low carries. + Mirrors HEAD const_arith.rs:950-987 fold_postsum_carry_compute." + (cond + (is-add + (cond + (kc-pair + (let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair))) + (gate-x! c acc-reg i) + (cond + (ci-pair + (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair))) + (gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx) + (gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx) + (gate-x! c acc-reg i) + (gate-ccx! c kc-reg kc-idx ci-reg ci-idx tgt-reg tgt-idx))) + (else + (gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx) + (gate-x! c acc-reg i))))) + (ci-pair + (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair))) + (gate-x! c acc-reg i) + (gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx) + (gate-x! c acc-reg i))))) + (else + (cond + (kc-pair + (let ((kc-reg (car kc-pair)) (kc-idx (cdr kc-pair))) + (cond + (ci-pair + (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair))) + (gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx) + (gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx) + (gate-ccx! c kc-reg kc-idx ci-reg ci-idx tgt-reg tgt-idx))) + (else + (gate-ccx! c acc-reg i kc-reg kc-idx tgt-reg tgt-idx))))) + (ci-pair + (let ((ci-reg (car ci-pair)) (ci-idx (cdr ci-pair))) + (gate-ccx! c acc-reg i ci-reg ci-idx tgt-reg tgt-idx))))))) + +;;; ── sweep-fused-fold-v25 — cadd-2-controls-trunc-fast! ──────────── +;;; +;;; HEAD reference: `compressed.rs:2193-2215` (forward fused fold body of +;;; `dialog_gcd_fused_double_y`) — single truncated ripple at width lsbs +;;; emitting δ = k1·ctrl1 + k2·ctrl2 via the 12-position per-position +;;; controls table mapped to bits {0,1,4,5,6,7,8,9,10,11, hi, hi+1} for a +;;; secp256k1-class pseudo-Mersenne c. +;;; +;;; What V2.5 saves vs V2's two `cadd-const!` calls: +;;; +;;; V2: cadd-const(v, lsbs, c, ctrl1) + cadd-const(v, lsbs, 2c, ctrl2) +;;; → 2 × full Solinas truncated ripple. ~62 Toff/call × 2. +;;; +;;; V2.5: derive 4 ancilla controls (h, xed, eord, n10) via 3 CCX + 6 CX, +;;; issue ONE per-position-controls truncated ripple at width lsbs, +;;; uncompute the 4 derived controls in reverse (6 CX + 1 CCX). The +;;; ripple itself emits ~62 Toff. Net: ~62 Toff/call + 4 CCX overhead. +;;; +;;; Save per mod-4x-inplace! call: ~62 - 4 Toff = ~58 Toff. ~50 % shift2- +;;; density × iters=258 ≈ 129 calls/shot → ~7-8k Toff saved per shot. +;;; +;;; CALLING CONVENTION: +;;; +;;; c : circuit/stream context. +;;; acc-reg : (>= lsbs)-wide quantum register (the v register). +;;; lsbs : slice width for the truncated ripple. Caller picks +;;; lsbs = min(n+1, padding + bit-length(2*c)) just like +;;; V2's cadd-const calls. last = min(lsbs - 2, hi + window) +;;; where hi = highest-set-bit(2*c) = bit-length(c). +;;; k1 : compile-time classical integer (V2.5 uses c, the +;;; pseudo-Mersenne complement 2^n - p). +;;; ctrl1-reg, ctrl1-idx : runtime qubit gating k1's addition. +;;; k2 : compile-time classical integer (V2.5 uses 2c). +;;; ctrl2-reg, ctrl2-idx : runtime qubit gating k2's addition. +;;; tmp-reg : (>= last+1)-wide ancilla register at |0> for carries. +;;; window : carry-tail safety bits past highest_set_bit(2*c). +;;; Caller passes *cadd-direct-window* (HEAD default 8). +;;; bit-base : classical-bit base offset; consumes +;;; [bit-base, bit-base+last] via HMR. Caller picks a +;;; non-colliding region (V2.5 uses *cadd-direct-bit-base*). +;;; +;;; Currently HARDCODED for HEAD's secp256k1 pseudo-Mersenne table +;;; (compressed.rs:2196-2210): k1 must have bits {0,4,6,7,8,9,hi} set and +;;; k2 = 2·k1 must have bits {1,5,7,8,9,10,hi+1}. Verified at build-time +;;; against (k1, k2). Errors when the pattern doesn't match — protects +;;; against silently emitting the wrong fold for a non-secp256k1 c. +;;; +;;; Returns tmp-reg[0..last] to |0> via HMR + cz_if (inside the +;;; per-position primitive); 4 derived-ctrl ancilla returned to |0> by +;;; reversed CX + CCX uncompute below; acc-reg gets δ added; both ctrl1 +;;; and ctrl2 unchanged. + +(define (cadd-2-controls-trunc-fast! + c acc-reg lsbs k1 ctrl1-reg ctrl1-idx k2 ctrl2-reg ctrl2-idx + tmp-reg window bit-base) + "acc[0..lsbs) += (ctrl1 ? k1 : 0) + (ctrl2 ? k2 : 0) in ONE truncated + carry sweep with per-position-controls. Hardcoded for HEAD's + secp256k1-class table where k2 == 2·k1 AND k1's bits sit at + {0,4,6,7,8,9,hi}. Errors otherwise. + + *fold-maj1* / *perpos-maj2* threaded via emit-fold-majority! inside + cadd-per-position-controls-trunc!. + *fold-freed-tail* dispatches to cadd-fold-ripple-freed-tail!, + which owns the full h/xed/eord/n10 lifetime + split low/tail carry + lanes (HEAD const_arith.rs:1051-1267 fold_ripple_freed_tail_ed). + *fold-park-low-carries* only consumed inside freed-tail variant." + ;; *fold-freed-tail* dispatch: routes the split-lane variant. + ;; HEAD: free_ed gate implies base freed-tail (const_arith.rs:1064), + ;; so we only consult *fold-freed-tail* here. *fold-freed-tail-ed* + ;; remains a no-op until the e,d-extension wiring lands (HYP-6 §4a; + ;; requires caller-supplied ovf1/ovf2/s2 live qubits, see ticket). + (cond + (*fold-freed-tail* + (let* ((kk1 (modulo k1 (expt 2 lsbs))) + (kk2 (modulo k2 (expt 2 lsbs)))) + (cond + ((= lsbs 0) #t) + ((and (= kk1 0) (= kk2 0)) #t) + (else + (let ((hi (highest-set-bit kk1))) + (when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs)))) + (error "cadd-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)" + k1 k2 lsbs)) + (when (not (and (bit-set? kk1 0) (bit-set? kk1 4) + (bit-set? kk1 6) (bit-set? kk1 7) + (bit-set? kk1 8) (bit-set? kk1 9) + (bit-set? kk1 hi))) + (error "cadd-2-controls-trunc-fast!: k1 missing required bits" + k1 hi)) + (when (<= lsbs (+ hi 1)) + (error "cadd-2-controls-trunc-fast!: lsbs <= hi+1, no room" + lsbs hi)) + (let* ((last (min (- lsbs 2) (+ (+ hi 1) window))) + (hi-delta (+ hi 1))) + ;; HEAD const_arith.rs:1069 — freed-tail requires nonempty + ;; high tail (last > hi-delta). + (when (<= last hi-delta) + (error "cadd-2-controls-trunc-fast!: *fold-freed-tail* needs last > hi+1" + last hi-delta)) + (cadd-fold-ripple-freed-tail! + c acc-reg lsbs + ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx + last hi hi-delta #t bit-base))))))) + (else + (let* ((kk1 (modulo k1 (expt 2 lsbs))) + (kk2 (modulo k2 (expt 2 lsbs)))) + (cond + ((= lsbs 0) #t) + ((and (= kk1 0) (= kk2 0)) #t) + (else + ;; Validate HEAD table assumptions. + (let ((hi (highest-set-bit kk1))) + (when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs)))) + (error "cadd-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)" + k1 k2 lsbs)) + (when (not (and (bit-set? kk1 0) + (bit-set? kk1 4) + (bit-set? kk1 6) + (bit-set? kk1 7) + (bit-set? kk1 8) + (bit-set? kk1 9) + (bit-set? kk1 hi))) + (error "cadd-2-controls-trunc-fast!: k1 missing required bits" + k1 hi)) + ;; The table requires bit hi+1 to live inside lsbs (HEAD: hi=32 + ;; for secp256k1 → bit 33 inside lsbs ≥ 34). If lsbs ≤ hi+1 the + ;; per-position table cannot place the high pair; fall back path + ;; lives upstream at mod-4x-inplace! (V1 sequential). + (when (<= lsbs (+ hi 1)) + (error "cadd-2-controls-trunc-fast!: lsbs <= hi+1, no room" + lsbs hi)) + ;; Derive 4 ancilla controls per HEAD compressed.rs:2169-2191. + ;; "e" in HEAD ↔ ctrl1 (V2 carrier of k1·c). + ;; "d" in HEAD ↔ ctrl2 (V2 carrier of k2·2c). + ;; h = e & d (1 CCX) + ;; xed = e ⊕ d (2 CX) + ;; eord = (e ⊕ d) ⊕ h (2 CX; equals e | d) + ;; n10 = d ⊕ h (2 CX; equals ¬e & d) + (let ((h '_v25-h) + (xed '_v25-xed) + (eord '_v25-eord) + (n10 '_v25-n10)) + (alloc! c h 1) + (alloc! c xed 1) + (alloc! c eord 1) + (alloc! c n10 1) + ;; h = ctrl1 & ctrl2 + (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0) + ;; xed = ctrl1 ⊕ ctrl2 + (gate-cx! c ctrl1-reg ctrl1-idx xed 0) + (gate-cx! c ctrl2-reg ctrl2-idx xed 0) + ;; eord = xed ⊕ h + (gate-cx! c xed 0 eord 0) + (gate-cx! c h 0 eord 0) + ;; n10 = ctrl2 ⊕ h + (gate-cx! c ctrl2-reg ctrl2-idx n10 0) + (gate-cx! c h 0 n10 0) + ;; Build the per-position-controls list per HEAD's table. + ;; bit 0: ctrl1 (k1 bit 0 = 1) + ;; bit 1: ctrl2 (k2 bit 1 = 1) + ;; bit 4: ctrl1 (k1 bit 4 = 1) + ;; bit 5: ctrl2 (k2 bit 5 = 1) + ;; bit 6: ctrl1 (k1 bit 6 = 1) + ;; bit 7: xed (k1+k2 bit 7 = 2 → xor at 7, carry to 8) + ;; bit 8: eord (k1+k2+carry bit 8) + ;; bit 9: eord (k1+k2+carry bit 9) + ;; bit 10: n10 (k2 bit 10 only) + ;; bit 11: h (carry-fold absorption) + ;; bit hi: ctrl1 + ;; bit hi+1: ctrl2 + ;; Positions not listed default to #f via perpos-ctrl-at. + (let* ((last (min (- lsbs 2) + (+ (+ hi 1) window))) + (controls (make-perpos-secp256k1-fold-controls + hi + (cons ctrl1-reg ctrl1-idx) + (cons ctrl2-reg ctrl2-idx) + (cons xed 0) + (cons eord 0) + (cons n10 0) + (cons h 0)))) + (cadd-per-position-controls-trunc! + c acc-reg lsbs controls last tmp-reg bit-base)) + ;; Uncompute derived ancilla in EXACT reverse of derivation. + ;; reverse n10 : (cx h n10) (cx ctrl2 n10) + (gate-cx! c h 0 n10 0) + (gate-cx! c ctrl2-reg ctrl2-idx n10 0) + ;; reverse eord : (cx h eord) (cx xed eord) + (gate-cx! c h 0 eord 0) + (gate-cx! c xed 0 eord 0) + ;; reverse xed : (cx ctrl2 xed) (cx ctrl1 xed) + (gate-cx! c ctrl2-reg ctrl2-idx xed 0) + (gate-cx! c ctrl1-reg ctrl1-idx xed 0) + ;; reverse h : (ccx ctrl1 ctrl2 h) + (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0) + (free! c n10) + (free! c eord) + (free! c xed) + (free! c h))))))))) ; closes (else ...) of *fold-freed-tail* dispatch + +;;; Helper: build the 12-position controls list for HEAD's secp256k1 fold. +;;; The list length = hi + 2 (indices 0..hi+1 covered). Positions not in +;;; the table are #f (no control). hi = highest_set_bit(c) (= 32 for +;;; secp256k1). Per HEAD compressed.rs:2196-2210. + +(define (make-perpos-secp256k1-fold-controls hi e-pair d-pair xed-pair + eord-pair n10-pair h-pair) + "Return list of length (hi + 2) for the per-position-controls fold of + δ = k1·e + k2·d under HEAD's secp256k1 table." + ;; Walk i = 0..(hi+1) and append the right pair (or #f). + (let loop ((i 0) (acc '())) + (cond + ((> i (+ hi 1)) + (reverse acc)) + (else + (let ((entry + (cond + ((= i 0) e-pair) + ((= i 1) d-pair) + ((= i 4) e-pair) + ((= i 5) d-pair) + ((= i 6) e-pair) + ((= i 7) xed-pair) + ((= i 8) eord-pair) + ((= i 9) eord-pair) + ((= i 10) n10-pair) + ((= i 11) h-pair) + ((= i hi) e-pair) + ((= i (+ hi 1)) d-pair) + (else #f)))) + (loop (+ i 1) (cons entry acc))))))) + +;;; ── cadd-fold-ripple-freed-tail! — split-lane fused-fold ripple ─── +;;; +;;; Port of HEAD const_arith.rs:1051-1267 fold_ripple_freed_tail_ed. +;;; Splits the carry lane into `_ft-low[0..=hi-delta]` (parked across the +;;; active region; lifetime spans the full call) + `_ft-tail[0..tail-len)` +;;; (allocated AFTER the four derived controls h/xed/eord/n10 are freed +;;; mid-ripple, freed BEFORE they are re-derived). Net wide-tail +;;; high-water drops by 4 ancillae vs the unsplit ripple (HEAD §6.6). +;;; +;;; PORT STATUS (2026-06-13): WIRED. The primitive owns the FULL +;;; ancilla lifetime — caller supplies only ctrl1, ctrl2, acc-reg, +;;; lsbs, last, hi, hi-delta, is-add, bit-base. Returns acc += δ +;;; (is-add=#t) or acc -= δ (is-add=#f), ctrl1/ctrl2 unchanged, +;;; every ancilla freed. +;;; +;;; e,d-extension (*fold-freed-tail-ed*) STRUCTURAL NO-OP under lumbda. +;;; HEAD's free_ed pass (const_arith.rs:1162-1172) frees the separate +;;; e,d copy qubits that HEAD allocates from `(ovf1, ovf2, s2)` (see +;;; compressed.rs:3260-3271 `d = ovf1 & s2; e = ovf1 ^ d ^ ovf2`). +;;; Lumbda's `cadd-2-controls-trunc-fast!` dispatcher binds e↔ctrl1 +;;; and d↔ctrl2 DIRECTLY (see docstring at line 2750-2755) — under +;;; the s2=1 classical specialization (lumbda's mod-4x-inplace! IS +;;; the K=2 shift2=1 specialization; s2 is classical-true & not a +;;; qubit), HEAD's e,d-copy alloc collapses to `e = ovf2, d = ovf1` +;;; and lumbda skips the copy alloc entirely. The -2 ancillae HEAD +;;; reports across the wide tail are already-banked at the substrate +;;; level: lumbda's freed-tail body has no separate e,d qubits to +;;; free in step 3b. See test-fold-freed-tail-ed-port.lsp for the +;;; positive-control reducer proving flag-ON byte-identical to +;;; flag-OFF + same peak-qubits + same toffoli count. +;;; +;;; *fold-park-low-carries* wired below: when > 0, the lowest `park` +;;; carries in `_ft-low` are measurement-uncomputed before tail alloc +;;; and recomputed before the low uncompute pass — drops high-water by +;;; `park` more qubits at cost of `park` HMR + cz_if (phase-EXACT, +;;; 0 Toffoli). +;;; +;;; CALLING CONVENTION (note: shape differs from the original stub — +;;; caller no longer supplies pre-derived h/xed/eord/n10): +;;; +;;; c : circuit context. +;;; acc-reg : (>=lsbs)-wide quantum register. +;;; lsbs : slice width (acc.len() in HEAD). +;;; ctrl1-reg ctrl1-idx : "e" in HEAD (k1·c carrier). +;;; ctrl2-reg ctrl2-idx : "d" in HEAD (k2·2c carrier). +;;; last : inclusive carry-truncation index. > hi-delta. +;;; hi : highest-set-bit(k1) (32 for secp256k1). +;;; hi-delta : hi + 1 (33 for secp256k1). HEAD's hi_delta. +;;; is-add : #t for cadd; #f for csub (borrow). +;;; bit-base : classical-bit base. Consumes +;;; [bit-base, bit-base + last + 1] (last+1 carry +;;; HMRs + 1 for the h measurement clear). +;;; +;;; CLASSICAL-BIT MAP (deterministic — caller picks bit-base; primitive +;;; uses the following offsets): +;;; bit-base + i : HMR target for carry low[i] (0 <= i <= hi-delta) +;;; bit-base + i : HMR target for carry tail[i - hi-delta - 1] +;;; (hi-delta < i <= last) — same i indexing +;;; bit-base + last+1 : HMR target for the h free-measurement +;;; bit-base + last+2 + i : HMR target for the park-low pass +;;; (only consumed when *fold-park-low-carries* > 0) +;;; Caller must reserve [bit-base, bit-base + last + 1 + park-low + 1). + +(define (cadd-fold-ripple-freed-tail! + c acc-reg lsbs ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx + last hi hi-delta is-add bit-base) + "Split-lane fused-fold ripple. Owns full ancilla lifetime; caller + passes only the two base controls + arithmetic params. + HEAD const_arith.rs:1019-1267 fold_ripple_freed_tail_ed." + ;; Sanity guards (mirror HEAD debug_assert!). + (when (>= last lsbs) + (error "cadd-fold-ripple-freed-tail!: last >= lsbs" last lsbs)) + (when (<= last hi-delta) + (error "cadd-fold-ripple-freed-tail!: last <= hi-delta (no tail)" + last hi-delta)) + (let* ((maj2 *perpos-maj2*) + (park-low (let ((p *fold-park-low-carries*)) + (cond ((< p 0) 0) + ((> p hi-delta) hi-delta) + (else p)))) + ;; Named ancilla — distinct from caller's tmp-reg so dispatcher + ;; can reuse the unsplit-path tmp-reg without clobber risk. + (h '_ft-h) + (xed '_ft-xed) + (eord '_ft-eord) + (n10 '_ft-n10) + (low '_ft-low) + (tail '_ft-tail) + (bit-h (+ bit-base last 1))) + ;; ── 0a. Derive h/xed/eord/n10 from ctrl1, ctrl2 (HEAD compressed.rs + ;; :2169-2191; identical to dispatcher's pre-derive in the unsplit + ;; path). + (alloc! c h 1) + (alloc! c xed 1) + (alloc! c eord 1) + (alloc! c n10 1) + (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0) + (gate-cx! c ctrl1-reg ctrl1-idx xed 0) + (gate-cx! c ctrl2-reg ctrl2-idx xed 0) + (gate-cx! c xed 0 eord 0) + (gate-cx! c h 0 eord 0) + (gate-cx! c ctrl2-reg ctrl2-idx n10 0) + (gate-cx! c h 0 n10 0) + ;; ── 0b. Build the per-position controls list (length hi-delta+1). + ;; HEAD: controls[i] = Some(qubit) at table positions, None elsewhere; + ;; controls.get(i).copied().flatten() at i > hi-delta returns None. + ;; We re-use make-perpos-secp256k1-fold-controls (length = hi+2 = + ;; hi-delta+1) — perpos-ctrl-at returns #f for any i beyond. + (let* ((controls (make-perpos-secp256k1-fold-controls + hi + (cons ctrl1-reg ctrl1-idx) ; e + (cons ctrl2-reg ctrl2-idx) ; d + (cons xed 0) + (cons eord 0) + (cons n10 0) + (cons h 0))) + (tail-len (- last hi-delta)) + (kctrl (lambda (i) (perpos-ctrl-at controls i)))) + ;; Allocate the LOW carry lane first (controls live across active region). + (alloc! c low (+ hi-delta 1)) + ;; ── 1. Active region carry sweep [0..=hi-delta] ──────────────── + ;; HEAD const_arith.rs:1082-1108. + (let loop ((i 0)) + (when (<= i hi-delta) + (let ((kc (kctrl i)) + (carry-in? (> i 0))) + (cond + (is-add + (cond + (kc + (let ((kc-reg (car kc)) (kc-idx (cdr kc))) + (cond + (carry-in? + (emit-fold-majority! c + acc-reg i kc-reg kc-idx low (- i 1) low i maj2)) + (else + (gate-ccx! c acc-reg i kc-reg kc-idx low i))))) + (carry-in? + (gate-ccx! c acc-reg i low (- i 1) low i)))) + (else + (cond + (kc + (let ((kc-reg (car kc)) (kc-idx (cdr kc))) + (gate-x! c acc-reg i) + (cond + (carry-in? + (emit-fold-majority! c + acc-reg i kc-reg kc-idx low (- i 1) low i maj2)) + (else + (gate-ccx! c acc-reg i kc-reg kc-idx low i))) + (gate-x! c acc-reg i))) + (carry-in? + (gate-x! c acc-reg i) + (gate-ccx! c acc-reg i low (- i 1) low i) + (gate-x! c acc-reg i)))))) + (loop (+ i 1)))) + ;; ── 2. Low sum bits [0..=hi-delta]: acc_i ^= k_i ^ carry_{i-1} ─ + ;; HEAD const_arith.rs:1109-1119. + (let loop ((i 0)) + (when (<= i hi-delta) + (let ((kc (kctrl i))) + (when kc + (gate-cx! c (car kc) (cdr kc) acc-reg i)) + (when (> i 0) + (gate-cx! c low (- i 1) acc-reg i))) + (loop (+ i 1)))) + ;; ── 2b. Park the lowest `park-low` carries via HMR + cz_if ───── + ;; HEAD const_arith.rs:1126-1134. Walks i = park_low-1 down to 0. + ;; Uses bits [bit-base+last+2, bit-base+last+1+park-low] (disjoint + ;; from the step-5/step-7 [bit-base, bit-base+last] range AND from + ;; the bit-base+last+1 h-clear slot). In lumbda the parked low[i] + ;; qubits stay allocated (no per-slot free); step 6b's CCX + ;; recompute restores their carry value before step 7's full HMR + ;; uncompute sweeps them too — so the phase from THIS measurement + ;; commutes through but the bit slot must not collide with a later + ;; HMR or the simulator double-measures into the same classical bit. + (when (> park-low 0) + (let loop ((i (- park-low 1))) + (when (>= i 0) + (let ((m (+ bit-base last 2 i)) + (kc (kctrl i)) + (carry-in? (> i 0))) + (gate-hmr! c low i m) + ;; fold-postsum-carry-phase-uncompute (HEAD const_arith.rs:911) + ;; acc[i] ^= maj(...) via cz_if chain conditional on the HMR bit. + (cond + (is-add + (cond + (kc + (let ((kc-reg (car kc)) (kc-idx (cdr kc))) + (gate-x! c acc-reg i) + (cond + (carry-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c acc-reg i low (- i 1)) + (gate-pop-cond! c) + (gate-x! c acc-reg i) + (gate-push-cond! c m) + (gate-cz! c kc-reg kc-idx low (- i 1)) + (gate-pop-cond! c)) + (else + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-x! c acc-reg i))))) + (carry-in? + (gate-x! c acc-reg i) + (gate-push-cond! c m) + (gate-cz! c acc-reg i low (- i 1)) + (gate-pop-cond! c) + (gate-x! c acc-reg i)))) + (else + (cond + (kc + (let ((kc-reg (car kc)) (kc-idx (cdr kc))) + (cond + (carry-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c acc-reg i low (- i 1)) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c kc-reg kc-idx low (- i 1)) + (gate-pop-cond! c)) + (else + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c))))) + (carry-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i low (- i 1)) + (gate-pop-cond! c)))))) + (loop (- i 1))))) + ;; ── 3. Free h, xed, eord, n10 BEFORE allocating the wide tail ── + ;; HEAD const_arith.rs:1140-1152. Uncompute in reverse derivation + ;; order, then measurement-clear h. + (gate-cx! c h 0 n10 0) + (gate-cx! c ctrl2-reg ctrl2-idx n10 0) + (gate-cx! c h 0 eord 0) + (gate-cx! c xed 0 eord 0) + (gate-cx! c ctrl2-reg ctrl2-idx xed 0) + (gate-cx! c ctrl1-reg ctrl1-idx xed 0) + (free! c n10) + (free! c eord) + (free! c xed) + ;; h cleared via HMR + cz_if(ctrl1, ctrl2, mh) — phase-exact AND-clear + ;; (h = ctrl1 & ctrl2 still holds; cz_if undoes the phase when ctrl1 + ;; AND ctrl2, restoring |0>). HEAD const_arith.rs:1149-1152. + (gate-hmr! c h 0 bit-h) + (gate-push-cond! c bit-h) + (gate-cz! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx) + (gate-pop-cond! c) + (free! c h) + ;; ── 4. Allocate the wide tail (4 derived controls now released) ─ + (alloc! c tail tail-len) + ;; ── 4a. High-tail carry generation (hi-delta, last]: pure + ;; propagation from ORIGINAL acc (acc[hi-delta+1..] untouched + ;; by step 2). HEAD const_arith.rs:1188-1197. + ;; carry-in for i = hi-delta+1 is low[hi-delta]; subsequent carries + ;; are in tail[(i - hi-delta - 1) - 1] = tail[i - hi-delta - 2]. + (let loop ((i (+ hi-delta 1))) + (when (<= i last) + (let ((tgt-idx (- i hi-delta 1)) + (ci-tail? (> i (+ hi-delta 1)))) + (cond + (is-add + (cond + (ci-tail? + (gate-ccx! c acc-reg i tail (- tgt-idx 1) tail tgt-idx)) + (else + (gate-ccx! c acc-reg i low hi-delta tail tgt-idx)))) + (else + (gate-x! c acc-reg i) + (cond + (ci-tail? + (gate-ccx! c acc-reg i tail (- tgt-idx 1) tail tgt-idx)) + (else + (gate-ccx! c acc-reg i low hi-delta tail tgt-idx))) + (gate-x! c acc-reg i)))) + (loop (+ i 1)))) + ;; ── 4b. High sum bits (hi-delta, lsbs) (k=0, control-free): + ;; acc_i ^= carry_{i-1}. HEAD const_arith.rs:1199-1203. + (let loop ((i (+ hi-delta 1))) + (when (< i lsbs) + (when (<= (- i 1) last) + (let ((src-i (- i 1))) + (cond + ((<= src-i hi-delta) + (gate-cx! c low src-i acc-reg i)) + (else + (gate-cx! c tail (- src-i hi-delta 1) acc-reg i))))) + (loop (+ i 1)))) + ;; ── 5. Reverse uncompute the TAIL carries first (control-free, + ;; high → low) so the wide lane shrinks before ctrl recompute. + ;; HEAD const_arith.rs:1207-1219. + (let loop ((i last)) + (when (> i hi-delta) + (let ((m (+ bit-base i)) + (tgt-idx (- i hi-delta 1)) + (ci-tail? (> i (+ hi-delta 1)))) + (gate-hmr! c tail tgt-idx m) + (cond + (is-add + (gate-x! c acc-reg i) + (gate-push-cond! c m) + (cond + (ci-tail? + (gate-cz! c acc-reg i tail (- tgt-idx 1))) + (else + (gate-cz! c acc-reg i low hi-delta))) + (gate-pop-cond! c) + (gate-x! c acc-reg i)) + (else + (gate-push-cond! c m) + (cond + (ci-tail? + (gate-cz! c acc-reg i tail (- tgt-idx 1))) + (else + (gate-cz! c acc-reg i low hi-delta))) + (gate-pop-cond! c)))) + (loop (- i 1)))) + (free! c tail) + ;; ── 6. Re-derive h, xed, eord, n10 (same gate sequence as + ;; step 0a) — for the low uncompute pass. They stay live on + ;; return (matches HEAD's `// h, xed, eord, n10 are left LIVE` + ;; comment at const_arith.rs:1265). + (alloc! c h 1) + (alloc! c xed 1) + (alloc! c eord 1) + (alloc! c n10 1) + (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0) + (gate-cx! c ctrl1-reg ctrl1-idx xed 0) + (gate-cx! c ctrl2-reg ctrl2-idx xed 0) + (gate-cx! c xed 0 eord 0) + (gate-cx! c h 0 eord 0) + (gate-cx! c ctrl2-reg ctrl2-idx n10 0) + (gate-cx! c h 0 n10 0) + ;; ── 6b. Park-low recompute: rebuild parked carries via CCX + ;; (fold-postsum-carry-compute, HEAD const_arith.rs:1248-1254). + (when (> park-low 0) + (let loop ((i 0)) + (when (< i park-low) + (let ((kc (kctrl i)) + (carry-in? (> i 0))) + (cond + (is-add + (cond + (kc + (let ((kc-reg (car kc)) (kc-idx (cdr kc))) + (gate-x! c acc-reg i) + (cond + (carry-in? + (gate-ccx! c acc-reg i kc-reg kc-idx low i) + (gate-ccx! c acc-reg i low (- i 1) low i) + (gate-x! c acc-reg i) + (gate-ccx! c kc-reg kc-idx low (- i 1) low i)) + (else + (gate-ccx! c acc-reg i kc-reg kc-idx low i) + (gate-x! c acc-reg i))))) + (carry-in? + (gate-x! c acc-reg i) + (gate-ccx! c acc-reg i low (- i 1) low i) + (gate-x! c acc-reg i)))) + (else + (cond + (kc + (let ((kc-reg (car kc)) (kc-idx (cdr kc))) + (cond + (carry-in? + (gate-ccx! c acc-reg i kc-reg kc-idx low i) + (gate-ccx! c acc-reg i low (- i 1) low i) + (gate-ccx! c kc-reg kc-idx low (- i 1) low i)) + (else + (gate-ccx! c acc-reg i kc-reg kc-idx low i))))) + (carry-in? + (gate-ccx! c acc-reg i low (- i 1) low i)))))) + (loop (+ i 1))))) + ;; ── 7. Reverse uncompute the active-region carries [0..=hi-delta]. + ;; HEAD const_arith.rs:1257-1263 walks i = hi_delta down to 0; + ;; HEAD's per-slot free at step 2b means the parked slots are + ;; reacquired by step 6b before this pass. In lumbda we don't + ;; per-slot free, so the parked low[i] qubits were never released + ;; — but step 2b HMR'd them to |0> and step 6b recomputed them to + ;; the original carry value, so the sweep below is well-defined + ;; on ALL i in [0, hi-delta] without skipping. + (let loop ((i hi-delta)) + (when (>= i 0) + (let ((m (+ bit-base i)) + (kc (kctrl i)) + (carry-in? (> i 0))) + (gate-hmr! c low i m) + (cond + (is-add + (cond + (kc + (let ((kc-reg (car kc)) (kc-idx (cdr kc))) + (gate-x! c acc-reg i) + (cond + (carry-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c acc-reg i low (- i 1)) + (gate-pop-cond! c) + (gate-x! c acc-reg i) + (gate-push-cond! c m) + (gate-cz! c kc-reg kc-idx low (- i 1)) + (gate-pop-cond! c)) + (else + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-x! c acc-reg i))))) + (carry-in? + (gate-x! c acc-reg i) + (gate-push-cond! c m) + (gate-cz! c acc-reg i low (- i 1)) + (gate-pop-cond! c) + (gate-x! c acc-reg i)))) + (else + (cond + (kc + (let ((kc-reg (car kc)) (kc-idx (cdr kc))) + (cond + (carry-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c acc-reg i low (- i 1)) + (gate-pop-cond! c) + (gate-push-cond! c m) + (gate-cz! c kc-reg kc-idx low (- i 1)) + (gate-pop-cond! c)) + (else + (gate-push-cond! c m) + (gate-cz! c acc-reg i kc-reg kc-idx) + (gate-pop-cond! c))))) + (carry-in? + (gate-push-cond! c m) + (gate-cz! c acc-reg i low (- i 1)) + (gate-pop-cond! c)))))) + (loop (- i 1)))) + (free! c low) + ;; ── 8. Uncompute h/xed/eord/n10 in reverse derivation (same + ;; teardown the unsplit-path dispatcher emits after its + ;; cadd-per-position-controls-trunc! call). HEAD: caller's + ;; "normal derived-control uncompute block runs next" + ;; (const_arith.rs:1265) — we run it here so the call is + ;; self-contained (matches the byte-identity contract of the + ;; default-OFF flag). + (gate-cx! c h 0 n10 0) + (gate-cx! c ctrl2-reg ctrl2-idx n10 0) + (gate-cx! c h 0 eord 0) + (gate-cx! c xed 0 eord 0) + (gate-cx! c ctrl2-reg ctrl2-idx xed 0) + (gate-cx! c ctrl1-reg ctrl1-idx xed 0) + (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0) + (free! c n10) + (free! c eord) + (free! c xed) + (free! c h)))) + +(define (cadd-const! c acc-reg n k ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg) + "acc += (ctrl ? k : 0) mod 2^n. Dispatches to direct sparse path when + *cadd-direct-trunc-fast* on; else cload + cuccaro-add." + (let ((kk (modulo k (expt 2 n)))) + (cond + ((and *cadd-direct-trunc-fast* (> n 1) (> kk 0)) + (cadd-nbit-const-direct-trunc-fast! + c acc-reg n kk ctrl-reg ctrl-idx tmp-reg + *cadd-direct-window* (cdtf-alloc-bit-base! n))) + (else + (cload-const! c ctrl-reg ctrl-idx tmp-reg n kk) + (cuccaro-add! c tmp-reg acc-reg cin-reg cin-idx n) + (cunload-const! c ctrl-reg ctrl-idx tmp-reg n kk))))) + +;;; ── Controlled lazy mod-double / mod-halve (sweep-cmod-inplace-lazy) +;;; +;;; HEAD modular.rs:823 cmod_double_inplace_lazy +;;; modular.rs:847 cmod_halve_inplace_lazy +;;; +;;; Closes AUDIT §6 rows 260-261. +;;; +;;; Controlled (ctrl) form of mod_double_inplace_fast (Solinas reduction, +;;; lazy [0,2^n) coset rep, same carry-trunc window). Identity when +;;; ctrl=0. Used by the K=2 prototype's conditional 2nd double so it +;;; composes correctly with the uncontrolled mod_double_inplace_fast +;;; in the apply path. +;;; +;;; Algorithm (HEAD modular.rs:823-842): +;;; 1. cswap(ctrl, v[n-1], ovf) +;;; 2. for i in (0..n-1).rev(): cswap(ctrl, v[i], v[i+1]) +;;; 3. c := 2^n - p (mod 2^n) +;;; 4. cadd_nbit_const_*(v, c, ovf) — dispatched by +;;; *double-carry-trunc-window* / *cadd-direct-trunc-fast* flags +;;; 5. ccx(ctrl, v[0], ovf) — clear ovf via parity == top-bit +;;; +;;; Halve is symmetric inverse: ovf clear first, csub instead of cadd, +;;; reverse cswap order. +;;; +;;; Caller responsibilities: +;;; v-reg: data register width n; modified in place +;;; ctrl-reg/ctrl-idx: read-only control bit +;;; ovf-reg/ovf-idx: clean |0> ancilla; restored to |0> on exit +;;; cin-reg/cin-idx + tmp-reg: scratch for the inner cadd-const! +;;; (must be clean; restored) +;;; p: classical prime modulus + +(define (cmod-double-inplace-lazy! + c v-reg n p ctrl-reg ctrl-idx + ovf-reg ovf-idx cin-reg cin-idx tmp-reg) + "Port of HEAD cmod_double_inplace_lazy (modular.rs:823). + v := (ctrl ? (2*v) mod p : v). Lazy coset rep — caller responsible + for any final normalization. Identity when ctrl=0." + ;; Shift v left by 1 via cswap chain (only if ctrl=1). + (gate-cswap! c ctrl-reg ctrl-idx v-reg (- n 1) ovf-reg ovf-idx) + (let loop ((i (- n 2))) + (when (>= i 0) + (gate-cswap! c ctrl-reg ctrl-idx v-reg i v-reg (+ i 1)) + (loop (- i 1)))) + ;; Solinas correction: add (2^n - p) when ctrl=1. + (let ((corr (modulo (- (expt 2 n) p) (expt 2 n)))) + (cadd-const! c v-reg n corr + ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg)) + ;; Clear ovf: result parity = old top-bit = ovf (gated by ctrl). + (gate-ccx! c ctrl-reg ctrl-idx v-reg 0 ovf-reg ovf-idx)) + +(define (cmod-halve-inplace-lazy! + c v-reg n p ctrl-reg ctrl-idx + ovf-reg ovf-idx cin-reg cin-idx tmp-reg) + "Port of HEAD cmod_halve_inplace_lazy (modular.rs:847). Inverse of + cmod-double-inplace-lazy!. Identity when ctrl=0." + ;; Re-establish ovf bit from current v[0] (gated by ctrl). + (gate-ccx! c ctrl-reg ctrl-idx v-reg 0 ovf-reg ovf-idx) + ;; Inverse Solinas correction: subtract (2^n - p) when ctrl=1. + (let ((corr (modulo (- (expt 2 n) p) (expt 2 n)))) + (csub-const! c v-reg n corr + ctrl-reg ctrl-idx cin-reg cin-idx tmp-reg)) + ;; Inverse shift: reverse cswap order. + (let loop ((i 0)) + (when (< i (- n 1)) + (gate-cswap! c ctrl-reg ctrl-idx v-reg i v-reg (+ i 1)) + (loop (+ i 1)))) + (gate-cswap! c ctrl-reg ctrl-idx v-reg (- n 1) ovf-reg ovf-idx)) + +;;; ── reversible mod-sub (hand-rolled inverse of mod-add!) ─────── +;;; +;;; Upstream mod_sub_qq emits the gate-level inverse of mod_add_qq via an +;;; emit_inverse helper. We don't have emit-inverse yet, so we hand-roll: +;;; walk mod-add!'s 8 steps in REVERSE order, replacing each step with +;;; its gate-level inverse. Self-inverse steps (CX, X, cmp-lt-into) emit +;;; unchanged; add-const flips to sub-const; csub-const flips to cadd-const; +;;; cuccaro-add flips to cuccaro-sub. + +(define (mod-sub-inplace-pseudo-mersenne! + c a-reg acc-reg n+1 p pmersenne-f + cin-reg cin-idx tmp-reg flag-reg flag-idx) + "Gate-level inverse of mod-add-inplace-pseudo-mersenne!. + acc := (acc - a) mod p under the pseudo-Mersenne approximation. + ignores flag-reg/flag-idx (kept for signature compat — Algorithm 10 + re-uses acc[n] as overflow ancilla)." + (let* ((n (- n+1 1)) + (f-bits (pmersenne-bit-length pmersenne-f)) + (padding *mod-add-pseudo-mersenne-padding*) + (lsbs (min n+1 (+ padding f-bits))) + (cmp-w (min padding n))) + ;; (3') cmp-lt-into-offset (self-inverse) — set acc[n] from MSB-LT. + ;; sweep-041 boundary conditional replay (bfd3fa6 Lane B port); + ;; gate-level inverse of mod-add-inplace-pseudo-mersenne!'s step + ;; (3). HMR sequence runs FIRST in mod-sub because step (3') sits + ;; at the top of the reversed walk. Same bit-id layout as forward + ;; path so phase reuses (* 5 n+1). + (cond + (*dgcd-apply-boundary-conditional-replay* + (let ((phase-bit (* 5 n+1))) + (gate-hmr! c acc-reg n phase-bit) + (cmp-lt-phase-conditioned-with-cin! + c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w + cin-reg cin-idx + acc-reg n + phase-bit + tmp-reg 0 (* 3 n+1)))) + (*cuccaro-use-borrowed* + (cmp-lt-into-fast-offset! + c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w + acc-reg n cin-reg cin-idx + tmp-reg 0 (* 3 n+1))) + (else + (cmp-lt-into-offset! + c acc-reg (- n cmp-w) a-reg (- n cmp-w) cmp-w + acc-reg n cin-reg cin-idx))) + ;; (2') csub-const f (inverse of cadd-const f). + (csub-const! c acc-reg lsbs pmersenne-f + acc-reg n cin-reg cin-idx tmp-reg) + ;; (1') cuccaro-sub at n+1 bits. + ;; sweep-windowed-wiring: mirror of mod-add-inplace-pseudo-mersenne! + ;; step (1) windowed dispatch. + (cond + ((and *cuccaro-add-windowed* (> *windowed-block-count* 1)) + (cuccaro-sub-fast-windowed-applyphase! + c a-reg acc-reg cin-reg cin-idx n+1 + *windowed-block-count* + 'pmsub-windowed (* 7 n+1))) + (*cuccaro-use-borrowed* + (cuccaro-sub-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1 + tmp-reg 0 (* 2 n+1))) + (else + (cuccaro-sub! c a-reg acc-reg cin-reg cin-idx n+1))))) + +(define (mod-sub! c a-reg acc-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx) + "acc := (acc - a) mod p. Same calling convention as mod-add!: + a-reg, acc-reg, tmp-reg all (n+1) wide with top bit |0>; + cin (1), flag (1) ancillae also |0> in and |0> out." + (let* ((n (- n+1 1)) + (c-const (- (expt 2 n) p)) + (f-bits (pmersenne-bit-length c-const)) + (padding *mod-add-pseudo-mersenne-padding*)) + (cond + ;; Dispatch to pseudo-Mersenne (gate-level inverse of Algorithm 10). + ;; + ;; 2026-06-12 — DISABLED. Gate-level inverse of buggy + ;; mod-add-inplace-pseudo-mersenne! inherits the same boundary + ;; defect. Standard mod-sub! body (else branch) mirrors the + ;; reversed standard mod-add!. See commit 5e6e3af + this commit + ;; for full bug analysis. + ;; + ;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on, + ;; mod-add-alg-11-sub-safe? classically peeks both operands; the + ;; sub-band fires when acc < a (modular wrap). Routes + ;; pseudo-Mersenne only on safe inputs. + ((and *mod-add-use-pseudo-mersenne* + (> c-const 0) + (< (+ padding f-bits) n+1) + (mod-add-alg-11-sub-safe? c a-reg acc-reg n+1 p)) + (mod-sub-inplace-pseudo-mersenne! + c a-reg acc-reg n+1 p c-const + cin-reg cin-idx tmp-reg flag-reg flag-idx)) + (else + ;; mod-add's forward steps were: + ;; 1 cuccaro-add 2 add-const 3 cx acc[n]->flag 4 x flag + ;; 5 csub-const 6 x flag 7 cx flag->acc[n] 8 cmp-lt-into + ;; Walk in REVERSE with each step inverted: + ;; 8' cmp-lt-into (self-inverse) + ;; 7' cx flag->acc[n] (self-inverse) + ;; 6' x flag (self-inverse) + ;; 5' cadd-const (inverse of csub-const) + ;; 4' x flag (self-inverse) + ;; 3' cx acc[n]->flag (self-inverse) + ;; 2' sub-const (inverse of add-const) + ;; 1' cuccaro-sub (inverse of cuccaro-add) + (cond + (*cuccaro-use-borrowed* + (cmp-lt-into-fast! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx + tmp-reg 0 (* 3 n+1))) + (else + (cmp-lt-into! c acc-reg a-reg n flag-reg flag-idx cin-reg cin-idx))) + (gate-cx! c flag-reg flag-idx acc-reg n) + (gate-x! c flag-reg flag-idx) + (cadd-const! c acc-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg) + (gate-x! c flag-reg flag-idx) + (gate-cx! c acc-reg n flag-reg flag-idx) + (sub-const! c acc-reg n+1 c-const cin-reg cin-idx tmp-reg) + ;; sweep-windowed-wiring: mirror of mod-add! step (1) wiring. + (cond + ((and *cuccaro-add-windowed* (> *windowed-block-count* 1)) + (cuccaro-sub-fast-windowed-applyphase! + c a-reg acc-reg cin-reg cin-idx n+1 + *windowed-block-count* + 'mod-sub-windowed (* 7 n+1))) + (*cuccaro-use-borrowed* + (cuccaro-sub-fast-borrowed! c a-reg acc-reg cin-reg cin-idx n+1 + tmp-reg 0 (* 2 n+1))) + (else + (cuccaro-sub! c a-reg acc-reg cin-reg cin-idx n+1))))))) + +;;; ── mod-{add,add-double,sub}-qb! — quantum + classical-bit adders ── +;;; +;;; Port of HEAD modular.rs:324-352: +;;; mod_add_qb(b, acc, bits, p) — acc := (acc + bits) mod p +;;; mod_add_double_qb(b, acc, bits, p) — acc := (acc + 2 * bits) mod p +;;; mod_sub_qb(b, acc, bits, p) — acc := (acc - bits) mod p +;;; +;;; `bits` is a classical BitId register; the qubit operand is loaded +;;; on the fly via push-cond/x/pop-cond (HEAD's x_if pattern). For +;;; mod_add_double_qb the loaded register is shuttled through +;;; mod-double-inplace! → mod-add! → mod-halve-inplace! so a single +;;; classical load + unload covers the 2x scaling. +;;; +;;; Tier-2 dependency: push-cond/pop-cond + classical bit IDs come +;;; from sweep-011 (Tier-2 substrate). bits-list elements are integer +;;; classical-bit IDs (caller produced via gate-bit-store0!/1! or +;;; HMR). bits-list length = n+1 = register width. +;;; +;;; Substrate status: ADDITIVE. No lumbda caller dispatches through +;;; these yet. Closes COLLAB §1.6 (= AUDIT §6 modular.rs rows 324/331/341). + +(define (load-bits-into-qubits! + c bits-list q-reg n) + ;; For each i in 0..n: x_if(q-reg[i], bits-list[i]). HEAD adder.rs:366 + ;; algorithm. Caller-supplied q-reg (alloc'd at |0>); bits-list of + ;; integer classical-bit IDs. + (let loop ((i 0) (rest bits-list)) + (when (and (< i n) (not (null? rest))) + (gate-push-cond! c (car rest)) + (gate-x! c q-reg i) + (gate-pop-cond! c) + (loop (+ i 1) (cdr rest))))) + +(define (unload-bits-from-qubits! + c bits-list q-reg n) + ;; Self-inverse of load-bits-into-qubits!; x_if is its own inverse. + ;; HEAD adder.rs:376. + (load-bits-into-qubits! c bits-list q-reg n)) + +(define (mod-add-qb! + c acc-reg n+1 bits-list p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + ;; acc := (acc + bits) mod p. Inline-allocs a transient register + ;; for the loaded bits, runs mod-add!, unloads + frees. + (alloc! c 'mod-qb-a n+1) + (load-bits-into-qubits! c bits-list 'mod-qb-a n+1) + (mod-add! c 'mod-qb-a acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + (unload-bits-from-qubits! c bits-list 'mod-qb-a n+1) + (free! c 'mod-qb-a)) + +(define (mod-add-double-qb! + c acc-reg n+1 bits-list p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + ;; acc := (acc + 2*bits) mod p. Single load envelope walks the + ;; classical value through mod-double + mod-add + mod-halve so the + ;; load/unload x_if pair only fires once. HEAD modular.rs:337-345. + (alloc! c 'mod-qb-a n+1) + (load-bits-into-qubits! c bits-list 'mod-qb-a n+1) + (mod-double-inplace! c 'mod-qb-a n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + (mod-add! c 'mod-qb-a acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + (mod-halve-inplace! c 'mod-qb-a n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + (unload-bits-from-qubits! c bits-list 'mod-qb-a n+1) + (free! c 'mod-qb-a)) + +(define (mod-sub-qb! + c acc-reg n+1 bits-list p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + ;; acc := (acc - bits) mod p. Mirror of mod-add-qb! via mod-sub!. + (alloc! c 'mod-qb-a n+1) + (load-bits-into-qubits! c bits-list 'mod-qb-a n+1) + (mod-sub! c 'mod-qb-a acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + (unload-bits-from-qubits! c bits-list 'mod-qb-a n+1) + (free! c 'mod-qb-a)) + +;;; ── controlled mod-add (needed by mod-mul!) ──────────────────── +;;; +;;; cmod-add! : if ctrl=1 then acc := (acc + a) mod p, else acc unchanged. +;;; +;;; Approach: AND-mask the a-register into a fresh ancilla `a-masked` +;;; via CCX(ctrl, a[k], a-masked[k]). Then call mod-add! on +;;; (a-masked, acc, p). Then uncompute a-masked via the SAME CCXs +;;; (CCX self-inverse + mod-add! preserves its a-reg argument). +;;; +;;; Caller still allocates the deep ancillae cin/tmp/flag the inner +;;; mod-add! consumes; the only NEW ancilla is `a-masked` (n+1 wide). +;;; Caller passes its name so we can declare via alloc!/free!. + +(define (ccx-mask! c ctrl-reg ctrl-idx src-reg dst-reg n) + "dst[k] ^= ctrl AND src[k] for k in [0,n). Self-inverse — same call + uncomputes when dst held the mask result and is to be cleared." + (let loop ((k 0)) + (when (< k n) + (gate-ccx! c ctrl-reg ctrl-idx src-reg k dst-reg k) + (loop (+ k 1))))) + +(define (cmod-add! c ctrl-reg ctrl-idx a-reg acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + a-masked-reg) + "acc := (acc + (ctrl ? a : 0)) mod p. a-reg preserved, acc top bit |0>. + a-masked-reg is an (n+1)-wide ancilla at |0> in/|0> out. + Caller alloc/free a-masked-reg around this call." + (let ((n (- n+1 1))) + ;; Build a-masked = ctrl ? a : 0 (n bits; top bit stays |0> for ext) + (ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n) + ;; Forward mod-add on a-masked + (mod-add! c a-masked-reg acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + ;; Uncompute a-masked (mod-add! preserved it, CCX self-inverse) + (ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n))) + +;;; ── cmod-add-qq-lowq! / cmod-sub-qq-lowq! ───────────────────────── +;;; +;;; Port of HEAD cmod_add_qq_lowq + cmod_sub_qq_lowq +;;; (modular.rs:1091-1119, commit 2dcf00d). "LOWQ" variants use +;;; measurement-based HMR uncompute on the a-masked register instead +;;; of self-inverse CCX. Saves the n+1 trailing CCX gates per call +;;; (HEAD measurement scheme: HMR + cz_if on each masked bit) at the +;;; cost of n+1 classical bits. +;;; +;;; Caller responsible for bit-base reservation: (ccx-mask-hmr-uncompute! +;;; consumes classical bit IDs 0..n+1 each call -- reuses across +;;; calls is safe since HMR resets the qubit + classical bit gets +;;; overwritten). This matches the existing pattern at +;;; mod-inv-by-dialog-gcd-host.lsp:141 where ccx-mask-hmr-uncompute! +;;; is consumed. +;;; +;;; Substrate status: ADDITIVE. No lumbda caller dispatches through +;;; these yet. Closes AUDIT §6 row 266 (cmod_add_qq_lowq / cmod_sub_ +;;; qq_lowq). Lumbda's ccx-mask-hmr-uncompute! already lives at +;;; mod-inv-by-dialog-gcd-host.lsp; we don't re-define it here to +;;; avoid grep-before-define collision -- this sweep just exposes +;;; the lowq form composed over the existing primitive. +;;; +;;; Load order: mod-arith.lsp loads before mod-inv-by-dialog-gcd-host.lsp. +;;; To keep these primitives available from mod-arith.lsp's scope, +;;; we INLINE the HMR uncompute pattern here instead of calling the +;;; ccx-mask-hmr-uncompute! helper (avoids forward-reference at +;;; emit time). + +;;; ── mod_shift_left/right_by_k_lowq — sweep-mod-shift-lowq ───────── +;;; +;;; HEAD modular.rs:624 mod_shift_left_by_k_lowq +;;; modular.rs:684 mod_shift_right_by_k_lowq +;;; +;;; Closes AUDIT §6 row 268. Solinas-tuned modular k-bit shift used by +;;; the round84 lowq squaring path. Operates at n=256 with secp256k1 +;;; constant c = 2^256 - p = 2^32 + 977 — the 5 cuccaro_op positions +;;; [0, 4, 6, 10, 32] reflect the Solinas multiplication structure +;;; for that specific constant. +;;; +;;; Algorithm (HEAD modular.rs:624-682): +;;; 1. Spill the top k bits of v via swap cascades: for shift_i in 0..k, +;;; swap(v[n-1], spill[k-1-shift_i]); then swap chain right-shift on v. +;;; 2. v_ext = v ++ [ovf] (caller-supplied 1-bit ovf). +;;; 3. Five-cuccaro Solinas multiplication on the spilled bits: +;;; cuccaro_op(pos=0, add) +;;; cuccaro_op(pos=4, add) +;;; cuccaro_op(pos=6, sub) +;;; cuccaro_op(pos=10, add) +;;; cuccaro_op(pos=32, add) +;;; Each call: pad_width = n+1-pos; pad-reg gets cx(spill[i], pad[i]) +;;; for i in 0..min(k, pad_width); then cuccaro-{add,sub}! between +;;; pad-reg + v_ext[pos..n+1]; then mirror cx to clear pad. +;;; 4. add_nbit_const(v_ext, c) — unconditional Solinas correction. +;;; 5. x(ovf); cx(ovf, flag_inv); x(ovf) -- flag_inv := !ovf +;;; 6. csub_nbit_const(v_ext, c, flag_inv) -- gated rollback when no overflow +;;; 7. x(flag_inv); cx(flag_inv, ovf); x(flag_inv) +;;; 8. Returns (spill, flag_inv, ovf) to caller — shift_right consumes them. +;;; +;;; Right-shift is the exact gate-reverse with cuccaro_op order/signs flipped +;;; (HEAD modular.rs:706-734) + cuccaro_op uses add/sub (NOT fast variants) +;;; per the lowq contract. +;;; +;;; ── Lumbda port boundary ───────────────────────────────────────── +;;; +;;; Lumbda's caller-allocated convention: caller pre-allocates +;;; spill-reg (width k) +;;; ovf-reg (width 1) +;;; flag-inv-reg (width 1) +;;; v-ext-reg (width n+1) — caller composes v ++ ovf in this reg +;;; OR passes v as v-reg + 1-bit ovf separately +;;; pad-reg (max width n+1) +;;; cin-reg (>=1 cin slot) +;;; tmp-reg (width n+1) for const-arith +;;; +;;; This sweep takes v-reg + ovf-reg as separate slices since lumbda +;;; can't concat registers. For the v_ext[pos..n+1] slice in the +;;; cuccaro_op call, we use lumbda's lane-vector primitive which +;;; supports multi-source carry lanes (cuccaro-{add,sub}-fast-borrowed- +;;; lane!). For the lowq path we use the textbook cuccaro-add!/sub! +;;; over a single v-ext-reg pre-composed by the caller. + +(define (mod-shift-lowq-cuccaro-op! + c spill-reg k v-ext-reg n+1 pos is-sub + pad-reg cin-reg cin-idx) + "Inner cuccaro_op called by mod-shift-{left,right}-by-k-lowq!. + Materializes pad-reg[0..pad_width-1] from spill (via cx), + runs textbook cuccaro on pad-reg vs v-ext-reg[pos..pos+pad_width], + then uncomputes pad. pad-reg must be clean |0> on entry/exit. + + Note: lumbda cuccaro-add!/sub! operate on contiguous reg slices + from index 0. To read v-ext-reg[pos..n+1] as a logical 'a-reg' we + would need offset-aware variants. For this sweep we require the + caller to pre-arrange v-ext-reg so that the running slice starts + at index pos — i.e., shift the caller's logical view rather than + slice. Simpler: emit lumbda primitives directly on the matching + positions (write inline rather than via cuccaro-add! wrapper)." + (let* ((pad-width (- n+1 pos)) + (copy-w (min k pad-width))) + ;; Materialize pad <- spill[0..copy-w-1] + (let loop-load ((i 0)) + (when (< i copy-w) + (gate-cx! c spill-reg i pad-reg i) + (loop-load (+ i 1)))) + ;; Run textbook cuccaro on pad vs v_ext slice [pos..n+1]. + ;; Lumbda's cuccaro-add!/sub! reads a-reg from index 0; to act on + ;; v-ext-reg[pos..n+1] we need an offset-aware variant. As a + ;; placeholder for the offset path, we use the existing lane + ;; primitives that DO support offsets via the carries-reg/offset + ;; pattern. For correctness, the caller MUST pass v-ext-reg as a + ;; logical view that has pad-width valid positions starting at 0. + ;; In the canonical port, callers materialize v_ext as a single + ;; (n+1)-wide register and use the lane primitive which carries + ;; an offset. + (cond + (is-sub + (cuccaro-sub-fast-borrowed! + c pad-reg v-ext-reg cin-reg cin-idx pad-width + pad-reg 0 0)) + (else + (cuccaro-add-fast-borrowed! + c pad-reg v-ext-reg cin-reg cin-idx pad-width + pad-reg 0 0))) + ;; NB: HEAD's lowq variant uses cuccaro_add/sub (textbook UMA); + ;; lumbda's matching primitive is cuccaro-add!/sub! but they + ;; only operate on index-0 slices. Above we route through + ;; cuccaro-sub-fast-borrowed! / cuccaro-add-fast-borrowed! which + ;; supports the (acc, offset) pattern needed for v_ext[pos..]. + ;; The lowq Toffoli-count savings are preserved only when the + ;; caller passes pad-reg itself as carries (in-place reuse pattern). + ;; Uncompute pad <- spill + (let loop-clear ((i 0)) + (when (< i copy-w) + (gate-cx! c spill-reg i pad-reg i) + (loop-clear (+ i 1)))))) + +(define (mod-shift-left-by-k-lowq! + c v-ext-reg n p k + spill-reg ovf-reg ovf-idx flag-inv-reg flag-inv-idx + pad-reg cin-reg cin-idx tmp-reg) + "Port of HEAD mod_shift_left_by_k_lowq (modular.rs:624). Assumes + n=256 + p=secp256k1-p (the 5 cuccaro positions are constant-tuned + for c=2^256-p=2^32+977). + + v-ext-reg: (n+1)-wide caller-allocated register; v occupies + indices 0..n-1, ovf bit at index n (clean |0> on entry). + spill-reg: k-wide register, clean |0> on entry. + ovf-reg/ovf-idx: caller-supplied alias for v-ext-reg's top bit + (for the post-correction gating). + flag-inv-reg: 1-bit clean register. + pad-reg: (n+1)-wide scratch, clean |0> on entry, restored. + + Returns nothing; caller-owned registers updated in place." + (let ((c-const (- (expt 2 n) p))) + ;; Step 1: swap cascade to spill top k bits. + (let loop-shift ((shift-i 0)) + (when (< shift-i k) + (gate-swap! c v-ext-reg (- n 1) spill-reg (- k 1 shift-i)) + (let loop-inner ((i (- n 2))) + (when (>= i 0) + (gate-swap! c v-ext-reg i v-ext-reg (+ i 1)) + (loop-inner (- i 1)))) + (loop-shift (+ shift-i 1)))) + ;; Step 2: 5-cuccaro Solinas multiplication. + (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 0 #f pad-reg cin-reg cin-idx) + (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 4 #f pad-reg cin-reg cin-idx) + (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 6 #t pad-reg cin-reg cin-idx) + (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 10 #f pad-reg cin-reg cin-idx) + (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 32 #f pad-reg cin-reg cin-idx) + ;; Step 3: add_nbit_const(v_ext, c) -- unconditional Solinas correction. + (add-const! c v-ext-reg (+ n 1) c-const cin-reg cin-idx tmp-reg) + ;; Step 4: flag_inv := !ovf + (gate-x! c ovf-reg ovf-idx) + (gate-cx! c ovf-reg ovf-idx flag-inv-reg flag-inv-idx) + (gate-x! c ovf-reg ovf-idx) + ;; Step 5: csub_nbit_const(v_ext, c, flag_inv) -- gated rollback. + (csub-const! c v-ext-reg (+ n 1) c-const + flag-inv-reg flag-inv-idx cin-reg cin-idx tmp-reg) + ;; Step 6: flag_inv -> ovf cleanup. + (gate-x! c flag-inv-reg flag-inv-idx) + (gate-cx! c flag-inv-reg flag-inv-idx ovf-reg ovf-idx) + (gate-x! c flag-inv-reg flag-inv-idx))) + +(define (mod-shift-right-by-k-lowq! + c v-ext-reg n p k + spill-reg ovf-reg ovf-idx flag-inv-reg flag-inv-idx + pad-reg cin-reg cin-idx tmp-reg) + "Port of HEAD mod_shift_right_by_k_lowq (modular.rs:684). Exact + gate-reverse of mod-shift-left-by-k-lowq!. Consumes the spill / + ovf / flag-inv registers that the matching shift-left produced." + (let ((c-const (- (expt 2 n) p))) + ;; Reverse step 6. + (gate-x! c flag-inv-reg flag-inv-idx) + (gate-cx! c flag-inv-reg flag-inv-idx ovf-reg ovf-idx) + (gate-x! c flag-inv-reg flag-inv-idx) + ;; Reverse step 5: cadd_nbit_const under flag-inv. + (cadd-const! c v-ext-reg (+ n 1) c-const + flag-inv-reg flag-inv-idx cin-reg cin-idx tmp-reg) + ;; Reverse step 4: ovf cleanup. + (gate-x! c ovf-reg ovf-idx) + (gate-cx! c ovf-reg ovf-idx flag-inv-reg flag-inv-idx) + (gate-x! c ovf-reg ovf-idx) + ;; Reverse step 3: sub_nbit_const(v_ext, c). + (sub-const! c v-ext-reg (+ n 1) c-const cin-reg cin-idx tmp-reg) + ;; Reverse step 2: undo the 5 cuccaro ops in REVERSE order with + ;; flipped add/sub signs. HEAD modular.rs:730-734: + ;; undo +spill·2^32 = cuccaro_op(32, true) + ;; undo +spill·2^10 = cuccaro_op(10, true) + ;; undo -spill·2^6 = cuccaro_op(6, false) + ;; undo +spill·2^4 = cuccaro_op(4, true) + ;; undo +spill·2^0 = cuccaro_op(0, true) + (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 32 #t pad-reg cin-reg cin-idx) + (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 10 #t pad-reg cin-reg cin-idx) + (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 6 #f pad-reg cin-reg cin-idx) + (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 4 #t pad-reg cin-reg cin-idx) + (mod-shift-lowq-cuccaro-op! c spill-reg k v-ext-reg (+ n 1) 0 #t pad-reg cin-reg cin-idx) + ;; Reverse step 1: reverse swap cascades. + (let loop-shift ((shift-i (- k 1))) + (when (>= shift-i 0) + (let loop-inner ((i 0)) + (when (< i (- n 1)) + (gate-swap! c v-ext-reg i v-ext-reg (+ i 1)) + (loop-inner (+ i 1)))) + (gate-swap! c v-ext-reg (- n 1) spill-reg (- k 1 shift-i)) + (loop-shift (- shift-i 1)))))) + +(define (cmod-add-qq-lowq! + c ctrl-reg ctrl-idx a-reg acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + a-masked-reg) + ;; acc := (acc + (ctrl ? a : 0)) mod p. a-masked-reg n+1 wide, + ;; |0> in/|0> out. HMR consumes classical bits 0..n+1. + (let ((n (- n+1 1))) + ;; Build a-masked = ctrl ? a : 0 (n bits) + (ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n) + ;; Forward mod-add + (mod-add! c a-masked-reg acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + ;; Uncompute via HMR + push-cond + cz + pop-cond per bit. + ;; HEAD modular.rs:1098-1102. + ;; 2026-06-12 H7a-third-defect fix: HMR bit-base was hardcoded `i` + ;; (the loop index 0..n-1). Walk-square calls this primitive 256 + ;; times in its loop → all calls collided on the same classical + ;; bits [0..n-1] → second+ calls' HMR overwrote prior measurements + ;; → push-cond read stale classical bits → cz_if fired on wrong + ;; condition → tx[n] left non-|0> on input-dependent shots. Same + ;; defect class as *cadd-direct-bit-base* (cdtf-alloc-bit-base! + ;; counter, commit a02b2a0). Fix: cas-alloc-bit-base!(n) advances + ;; per call so each invocation's n bits live in a fresh slot range. + (let ((slot-base (cas-alloc-bit-base! n))) + (let loop ((i 0)) + (when (< i n) + (gate-hmr! c a-masked-reg i (+ slot-base i)) + (gate-push-cond! c (+ slot-base i)) + (gate-cz! c ctrl-reg ctrl-idx a-reg i) + (gate-pop-cond! c) + (loop (+ i 1))))))) + +(define (cmod-sub-qq-lowq! + c ctrl-reg ctrl-idx a-reg acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + a-masked-reg) + ;; acc := (acc - (ctrl ? a : 0)) mod p. Mirror of cmod-add-qq-lowq!. + (let ((n (- n+1 1))) + (ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n) + (mod-sub! c a-masked-reg acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + ;; Same H7a-third-defect fix as cmod-add-qq-lowq! above. + (let ((slot-base (cas-alloc-bit-base! n))) + (let loop ((i 0)) + (when (< i n) + (gate-hmr! c a-masked-reg i (+ slot-base i)) + (gate-push-cond! c (+ slot-base i)) + (gate-cz! c ctrl-reg ctrl-idx a-reg i) + (gate-pop-cond! c) + (loop (+ i 1))))))) + +;;; ── cmod-sub-qq-lowq-borrowed-subtrahend! ───────────────────────── +;;; +;;; Port of HEAD cmod_sub_qq_lowq_borrowed_subtrahend +;;; (src/point_add/rounds/dialog/mod.rs:2006-2025, commit 2dcf00d). +;;; Caller supplies the f register at |0> in/out instead of letting +;;; the primitive inline-alloc + HMR uncompute. Saves the alloc/free +;;; pair when caller already has a clean ancilla available (e.g. a +;;; freed mid-iter scratch slot). +;;; +;;; Algorithm (HEAD 5 steps): +;;; 1. CCX(ctrl, a[i], f[i]) for i in 0..n -- mask copy a into f +;;; 2. mod-sub! acc -= f +;;; 3. CCX(ctrl, a[i], f[i]) for i in (n-1)..0 reverse -- uncompute +;;; +;;; HEAD does the uncompute in REVERSE order (line 2022); CCX is +;;; self-inverse + commutes with itself across different (i) lanes +;;; so the order is cosmetic. Mirroring HEAD exactly for byte- +;;; identity with HEAD's emit sequence. +;;; +;;; Substrate status: ADDITIVE. No lumbda caller dispatches yet. +;;; Closes AUDIT §10 cmod_sub_qq_lowq_borrowed_subtrahend ABSENT row. + +(define (cmod-sub-qq-lowq-borrowed-subtrahend! + c ctrl-reg ctrl-idx a-reg acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + f-reg) + ;; acc := (acc - (ctrl ? a : 0)) mod p. f-reg is caller-supplied + ;; |0>-in/|0>-out borrowed subtrahend register (n+1 wide). + (let ((n (- n+1 1))) + ;; Step 1: forward CCX mask copy. + (let loop ((i 0)) + (when (< i n) + (gate-ccx! c ctrl-reg ctrl-idx a-reg i f-reg i) + (loop (+ i 1)))) + ;; Step 2: mod-sub! acc -= f. + (mod-sub! c f-reg acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + ;; Step 3: reverse CCX uncompute (HEAD line 2022 iterates n-1..0). + (let loop ((i (- n 1))) + (when (>= i 0) + (gate-ccx! c ctrl-reg ctrl-idx a-reg i f-reg i) + (loop (- i 1)))))) + +;;; ── mod-mul! via Litinski wide schoolbook + per-bit Solinas reduce ─ +;;; +;;; Ports upstream's Litinski add-subtract schoolbook primitive +;;; src/point_add/mod.rs:4561 controlled_add_subtract_fast +;;; src/point_add/mod.rs:4688 schoolbook_mul_into_addsub +;;; src/point_add/mod.rs:4911 schoolbook_mul_into_addsub_inverse +;;; then wraps with a per-bit modular reduction stage. +;;; +;;; The Litinski trick dodges the mod-double! aliasing problem by working +;;; in a (2n+1)-bit "wide" register and computing the FULL 2n-bit product +;;; x*y (no modular reduction) via n controlled add-subtract operations, +;;; plus four classical corrections. Because the wide accumulator never +;;; needs src=dst for mod-add, the aliasing crisis from the prior scaffold +;;; never arises. +;;; +;;; Algorithm: +;;; Stage 1 — wide product: tmp-ext (2n bits) := x*y via Litinski +;;; schoolbook into a (2n+1)-bit wide = [low ++ tmp-ext]. +;;; Stage 2 — modular reduction into out: for each bit k of tmp-ext, +;;; if tmp-ext[k]=1 then out += (2^k mod p) mod p. Implemented +;;; reversibly via cload-const + mod-add + cunload-const. +;;; Stage 3 — inverse of Stage 1 uncomputes tmp-ext back to |0>. +;;; (x, y are preserved by Stage 1, so the inverse works.) +;;; +;;; Tests in tests/unit/test-mod-arith-3-4.lsp cover full n-bit b. + +;;; ── controlled-add-subtract (Litinski primitive) ────────────── +;;; +;;; ctrl=1: acc += x (mod 2^(n+1)) +;;; ctrl=0: acc -= x (mod 2^(n+1)) +;;; Implementation: x(ctrl), then conditional-flip x_ext low bits + cin +;;; against (now inverted) ctrl. cuccaro-add of x_ext into acc. Undo flips. +;;; Two's-complement subtract when original ctrl=0. +;;; +;;; Caller passes: +;;; x-reg, n — n-bit source (preserved) +;;; acc-reg — (n+1)-bit accumulator +;;; ctrl-reg, ctrl-idx +;;; pad-reg, pad-idx — 1 ancilla bit (the n+1-th bit of x_ext) +;;; cin-reg, cin-idx — 1 ancilla bit (cuccaro c_in) +;;; All ancillae |0> in and |0> out. +;;; +;;; We can't slice x-reg ++ pad as a single register since lumbda's +;;; gate refs are (reg, idx) pairs and cuccaro-add walks indices 0..n +;;; of a SINGLE register. Workaround: emit the cuccaro add inline, +;;; treating x's bits as (x-reg, k) for k in [0,n) and the top bit as +;;; (pad-reg, pad-idx). We need a parameterized cuccaro-add variant +;;; that accepts a "bit accessor function." Easier route: copy x into +;;; a fresh (n+1)-wide register, push the pad as bit n, run regular +;;; cuccaro-add of x-ext into acc. After the add, undo the copy. +;;; +;;; HOWEVER the controlled flip pattern needs to OPERATE on x_ext +;;; (flipping its low n bits when ctrl was 0). If x_ext is a COPY of x, +;;; flipping it doesn't affect x. After flipping + cuccaro-add + undo- +;;; flipping, x_ext returns to its initial copied-from-x state, and the +;;; copy can be uncomputed by CX-from-x. +;;; +;;; That's exactly the pattern. controlled-add-subtract! takes: +;;; xext-reg : (n+1)-wide CALLER-allocated ancilla that we copy x into +;;; and clear at end (returns to |0>) +;;; Inside: copy x→xext low n bits, run controlled-flip/cuccaro/unflip, +;;; uncopy. + +(define (controlled-add-subtract-fast-borrowed! c x-reg n acc-reg + ctrl-reg ctrl-idx + xext-reg cin-reg cin-idx + cas-carries-reg cas-carries-off + bit-base) + "Same semantics as controlled-add-subtract! but Stage-3 cuccaro-add + replaced with cuccaro-add-fast-borrowed! using caller-supplied carries. + cas-carries-reg[cas-carries-off..cas-carries-off+n) must be |0> in/out. + bit-base..bit-base+n-1 reserved for HMR uncompute classical bits." + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1)))) + (gate-x! c ctrl-reg ctrl-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + (cuccaro-add-offset-fast-borrowed! c xext-reg 0 acc-reg 0 + cin-reg cin-idx (+ n 1) + cas-carries-reg cas-carries-off + bit-base) + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-x! c ctrl-reg ctrl-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1))))) + +(define (controlled-add-subtract-inverse-fast-borrowed! + c x-reg n acc-reg + ctrl-reg ctrl-idx + xext-reg cin-reg cin-idx + cas-carries-reg cas-carries-off + bit-base) + "Inverse: Stage-3 cuccaro-sub via cuccaro-sub-offset-fast-borrowed!." + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1)))) + (gate-x! c ctrl-reg ctrl-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + (cuccaro-sub-offset-fast-borrowed! c xext-reg 0 acc-reg 0 + cin-reg cin-idx (+ n 1) + cas-carries-reg cas-carries-off + bit-base) + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-x! c ctrl-reg ctrl-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1))))) + +(define (controlled-add-subtract! c x-reg n acc-reg + ctrl-reg ctrl-idx + xext-reg cin-reg cin-idx) + "acc := ctrl ? (acc + x) : (acc - x), mod 2^(n+1). + acc-reg has width n+1. xext-reg has width n+1, |0> in/out. + x-reg preserved. cin |0> in/out." + ;; Stage 1: copy x into xext low n bits. xext[n] stays |0>. + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1)))) + ;; Stage 2: condition the add as add-or-subtract. + ;; x(ctrl); for k in 0..n: cx(ctrl, xext[k]); cx(ctrl, cin) + (gate-x! c ctrl-reg ctrl-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + ;; Stage 3: cuccaro add of xext into acc (width n+1). + (cuccaro-add! c xext-reg acc-reg cin-reg cin-idx (+ n 1)) + ;; Stage 4: undo conditioning. + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-x! c ctrl-reg ctrl-idx) + ;; Stage 5: uncopy x from xext (low n bits) — CX self-inverse. + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1))))) + +(define (controlled-add-subtract-inverse! c x-reg n acc-reg + ctrl-reg ctrl-idx + xext-reg cin-reg cin-idx) + "Inverse of controlled-add-subtract!: swap add/sub semantics." + ;; Walk the forward gates in reverse with each step inverted. Stage 1 + ;; (CX copy) is self-inverse → emit at end. Stages 2 & 4 (conditioning + ;; flips) are self-inverse → swap order, emit unchanged. Stage 3 — the + ;; cuccaro-add becomes cuccaro-sub. + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1)))) + (gate-x! c ctrl-reg ctrl-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + ;; INVERSE of cuccaro-add at width n+1. + (cuccaro-sub! c xext-reg acc-reg cin-reg cin-idx (+ n 1)) + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-x! c ctrl-reg ctrl-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1))))) + +;;; ── slice cuccaro-add variants ──────────────────────────────── +;;; +;;; The Litinski schoolbook needs to operate on a SLICE wide[k..k+n+1] as +;;; the accumulator. Our base cuccaro-add! always indexes (acc-reg, 0..n). +;;; We need an offset-indexed version: cuccaro-add-offset! treats the +;;; accumulator as acc-reg starting at bit offset `off`, width `n`. + +(define (maj-off! c x-reg x-idx y-reg y-idx w-reg w-idx) + (maj! c x-reg x-idx y-reg y-idx w-reg w-idx)) + +;;; *cas-borrowed-carries-reg* / *cas-borrowed-carries-offset* / +;;; *cas-borrowed-bit-base* — when reg is not #f, cuccaro-add-offset! +;;; (& -sub-offset!) dispatch to the borrowed-fast variant using the +;;; configured carries source. Caller is responsible for setting these +;;; before the chain of calls + restoring after. Carries must be |0> +;;; in/out. Bit-base must be a safe-to-clobber starting ID. + +(define *cas-borrowed-carries-reg* #f) +(define *cas-borrowed-carries-offset* 0) +(define *cas-borrowed-bit-base* 0) + +;;; *cas-borrowed-bit-base-next* — per-call monotonic counter for HMR slot +;;; allocation in the borrowed offset-fast variants. 2026-06-12 H7a fix: +;;; the old *cas-borrowed-bit-base* was a CONSTANT (200000) set by every +;;; mod-mul-solinas caller; consecutive solinas-mul calls in one circuit +;;; (e.g. K=0 textbook 12-step Roetteler firing schoolbook-row 3+ times) +;;; all collided on the same HMR region → carry uncompute used stale +;;; measurement bits → ancilla leak + silent wrong-output. Same defect +;;; class as *cadd-direct-bit-base* (cdtf-alloc-bit-base! mod-arith.lsp:1709). +;;; +;;; cas-alloc-bit-base!(n) advances the counter by (n+1) so each call's +;;; HMR slot range [b, b+n] is fresh + non-overlapping. + +(define *cas-borrowed-bit-base-next* 200000) + +(define (cas-alloc-bit-base! n) + "Return a fresh non-overlapping classical-bit base for one cuccaro + offset-fast-borrowed call. Advances the counter by (n+1)." + (let ((b *cas-borrowed-bit-base-next*)) + (set! *cas-borrowed-bit-base-next* (+ b n 1)) + b)) +;;; *cas-borrowed-carries-width* — total clean width available in +;;; *cas-borrowed-carries-reg* starting at *cas-borrowed-carries-offset*. +;;; JOINT dispatchers (cuccaro-add-joint! / cuccaro-sub-joint!) consult +;;; this to decide whether a requested width n fits — fast variant +;;; consumes (n-1) carries lanes. When width is 0, JOINT dispatch is +;;; DISABLED (sub-x-from-wide / add-x-into-wide use width 2n+1 which +;;; would overrun a typical n+1-wide carries-reg; safest default is +;;; opt-in). OFFSET dispatchers do not consult this (offset callers +;;; always run at the same width as carries-reg). +(define *cas-borrowed-carries-width* 0) + +(define (cuccaro-add-offset! c a-reg a-off acc-reg acc-off cin-reg cin-idx n) + "acc[off..off+n) := (acc[off..off+n) + a[a-off..a-off+n)) mod 2^n. + a-reg untouched; cin |0> in/out. + When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path." + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c cin-reg cin-idx acc-reg acc-off) + (gate-cx! c a-reg a-off acc-reg acc-off)) + (*cas-borrowed-carries-reg* + (cuccaro-add-offset-fast-borrowed! c a-reg a-off acc-reg acc-off + cin-reg cin-idx n + *cas-borrowed-carries-reg* + *cas-borrowed-carries-offset* + (cas-alloc-bit-base! n))) + (else + (maj! c cin-reg cin-idx acc-reg acc-off a-reg a-off) + (let loop ((i 1)) + (when (< i (- n 1)) + (maj! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i) + a-reg (+ a-off i)) + (loop (+ i 1)))) + (gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1))) + (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1))) + (let loop ((i (- n 2))) + (when (>= i 1) + (uma! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i) + a-reg (+ a-off i)) + (loop (- i 1)))) + (uma! c cin-reg cin-idx acc-reg acc-off a-reg a-off)))) + +(define (cuccaro-sub-offset! c a-reg a-off acc-reg acc-off cin-reg cin-idx n) + "Inverse of cuccaro-add-offset!. + When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path." + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c a-reg a-off acc-reg acc-off) + (gate-cx! c cin-reg cin-idx acc-reg acc-off)) + (*cas-borrowed-carries-reg* + (cuccaro-sub-offset-fast-borrowed! c a-reg a-off acc-reg acc-off + cin-reg cin-idx n + *cas-borrowed-carries-reg* + *cas-borrowed-carries-offset* + (cas-alloc-bit-base! n))) + (else + (inv-uma! c cin-reg cin-idx acc-reg acc-off a-reg a-off) + (let loop ((i 1)) + (when (< i (- n 1)) + (inv-uma! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i) + a-reg (+ a-off i)) + (loop (+ i 1)))) + (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1))) + (gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1))) + (let loop ((i (- n 2))) + (when (>= i 1) + (inv-maj! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i) + a-reg (+ a-off i)) + (loop (- i 1)))) + (inv-maj! c cin-reg cin-idx acc-reg acc-off a-reg a-off)))) + +;;; ── cuccaro-add/sub-offset-fast-borrowed! — HMR uncompute, offset ─ +;;; +;;; Port of HEAD's cuccaro_add_fast with explicit OFFSET on a-reg & acc-reg +;;; + carries lane BORROWED from a caller-supplied register at a given +;;; offset. Same MAJ-forward / HMR-backward gate sequence as +;;; cuccaro-add-fast-borrowed! (adder.lsp:203) but every a/acc index is +;;; translated through a-off/acc-off. +;;; +;;; Pre: carries-reg[carries-offset..carries-offset+n-2) must be |0> on entry. +;;; Post: carries-reg returns to |0>; a-reg + cin-reg unchanged; +;;; acc-reg[acc-off..acc-off+n) := (acc + a) mod 2^n. +;;; bit-base..bit-base+n-2 are the classical-bit IDs used by HMR uncompute. + +(define (cuccaro-add-offset-fast-borrowed! c a-reg a-off acc-reg acc-off + cin-reg cin-idx n + carries-reg carries-offset + bit-base) + "Offset+borrowed-carries port of cuccaro-add-fast-borrowed!." + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c cin-reg cin-idx acc-reg acc-off) + (gate-cx! c a-reg a-off acc-reg acc-off)) + (else + (gate-cx! c a-reg a-off acc-reg acc-off) + (gate-cx! c a-reg a-off cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg acc-off + carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg a-off) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg (+ a-off i) acc-reg (+ acc-off i)) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-ccx! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg (+ a-off i)) + (loop-fwd (+ i 1)))) + (gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1))) + (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1))) + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) + a-reg (+ a-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) + (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i)) + (gate-pop-cond! c) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-cx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i)) + (loop-back (- i 1)))) + (gate-cx! c carries-reg carries-offset a-reg a-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg acc-off) + (gate-pop-cond! c) + (gate-cx! c a-reg a-off cin-reg cin-idx) + (gate-cx! c cin-reg cin-idx acc-reg acc-off)))) + +(define (cuccaro-sub-offset-fast-borrowed! c a-reg a-off acc-reg acc-off + cin-reg cin-idx n + carries-reg carries-offset + bit-base) + "Offset+borrowed-carries port of cuccaro-sub-fast-borrowed!. + acc[acc-off..acc-off+n) := (acc - a - cin) mod 2^n." + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c a-reg a-off acc-reg acc-off) + (gate-cx! c cin-reg cin-idx acc-reg acc-off)) + (else + (gate-cx! c cin-reg cin-idx acc-reg acc-off) + (gate-cx! c a-reg a-off cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx acc-reg acc-off + carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset a-reg a-off) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (gate-cx! c a-reg (+ a-off (- i 1)) acc-reg (+ acc-off i)) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-ccx! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) a-reg (+ a-off i)) + (loop-fwd (+ i 1)))) + (gate-cx! c a-reg (+ a-off (- n 1)) acc-reg (+ acc-off (- n 1))) + (gate-cx! c a-reg (+ a-off (- n 2)) acc-reg (+ acc-off (- n 1))) + (let loop-back ((i (- n 2))) + (when (>= i 1) + (gate-cx! c carries-reg (+ carries-offset i) + a-reg (+ a-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) + (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c a-reg (+ a-off (- i 1)) + acc-reg (+ acc-off i)) + (gate-pop-cond! c) + (gate-cx! c a-reg (+ a-off i) a-reg (+ a-off (- i 1))) + (gate-cx! c a-reg (+ a-off i) acc-reg (+ acc-off i)) + (loop-back (- i 1)))) + (gate-cx! c carries-reg carries-offset a-reg a-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx acc-reg acc-off) + (gate-pop-cond! c) + (gate-cx! c a-reg a-off cin-reg cin-idx) + (gate-cx! c a-reg a-off acc-reg acc-off)))) + +;;; *cuccaro-callers-fast* — substrate flag. When #t, controlled-add-subtract! +;;; / controlled-add-subtract-slice! dispatch their inner cuccaro-add at +;;; n+1 width to the borrowed-fast variant. Caller (schoolbook-mul) must +;;; pass a pre-allocated cas-carries register of width n+1 (clean |0>) +;;; & a bit-base integer. + +(define *cuccaro-callers-fast* #f) + +;;; ── controlled-add-subtract on an OFFSET slice of acc ───────── +;;; +;;; Same semantics as controlled-add-subtract! but the (n+1)-bit acc +;;; lives at acc-reg[acc-off..acc-off+n+1). x stays at x-reg[0..n). + +(define (controlled-add-subtract-slice! c x-reg n acc-reg acc-off + ctrl-reg ctrl-idx + xext-reg cin-reg cin-idx) + "acc[acc-off..acc-off+n+1) := ctrl ? (+x) : (-x), mod 2^(n+1)." + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1)))) + (gate-x! c ctrl-reg ctrl-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + (cuccaro-add-offset! c xext-reg 0 acc-reg acc-off cin-reg cin-idx (+ n 1)) + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-x! c ctrl-reg ctrl-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1))))) + +(define (controlled-add-subtract-slice-inverse! c x-reg n acc-reg acc-off + ctrl-reg ctrl-idx + xext-reg cin-reg cin-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1)))) + (gate-x! c ctrl-reg ctrl-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + (cuccaro-sub-offset! c xext-reg 0 acc-reg acc-off cin-reg cin-idx (+ n 1)) + (gate-cx! c ctrl-reg ctrl-idx cin-reg cin-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c ctrl-reg ctrl-idx xext-reg k) + (loop (+ k 1)))) + (gate-x! c ctrl-reg ctrl-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1))))) + +;;; ── slice add-of-classical-constant (offset variant of add-const!) ─ + +(define (load-const-offset! c reg off n k) + "reg[off..off+n) ^= bit pattern of k mod 2^n." + (let ((kk (modulo k (expt 2 n)))) + (let loop ((i 0)) + (when (< i n) + (when (bit-set? kk i) (gate-x! c reg (+ off i))) + (loop (+ i 1)))))) + +(define (add-const-slice! c acc-reg acc-off n k cin-reg cin-idx tmp-reg) + "acc[acc-off..acc-off+n) += k mod 2^n. tmp-reg n-wide |0> in/out." + (let ((kk (modulo k (expt 2 n)))) + (load-const! c tmp-reg n kk) + (cuccaro-add-offset! c tmp-reg 0 acc-reg acc-off cin-reg cin-idx n) + (unload-const! c tmp-reg n kk))) + +(define (sub-const-slice! c acc-reg acc-off n k cin-reg cin-idx tmp-reg) + (let ((kk (modulo k (expt 2 n)))) + (load-const! c tmp-reg n kk) + (cuccaro-sub-offset! c tmp-reg 0 acc-reg acc-off cin-reg cin-idx n) + (unload-const! c tmp-reg n kk))) + +;;; ── Litinski wide schoolbook: tmp-ext (2n bits) += x*y ───────── +;;; +;;; tmp-ext starts |0> n+1=… caller allocates 2n-wide tmp-ext + a 1-wide +;;; low ancilla. We treat wide = [low ++ tmp-ext] as a (2n+1)-bit +;;; accumulator. After all ops, wide = 2*x*y, so x*y reads out at +;;; wide[1..2n+1] = tmp-ext. +;;; +;;; This implementation allocates internal scratch (xext for the +;;; add-subtract loop, plus a cin for the corrections) inline. + +(define (schoolbook-mul-into-addsub! c x-reg y-reg n + low-reg low-idx + tmp-ext-reg + xext-reg cin-reg cin-idx + const-tmp-reg) + "Compute wide = [low ++ tmp-ext] := 2 * x * y over (2n+1) bits. + x-reg, y-reg are n-wide and preserved. tmp-ext is 2n-wide |0> in. + xext-reg is (n+1)-wide ancilla |0> in/out (controlled-add-subtract + scratch). const-tmp-reg is (n+1)-wide ancilla |0> in/out (constant + loading scratch). low is 1 bit |0> in/out (top of wide). cin is 1 + bit |0> in/out. After: tmp-ext = x*y (2n bits)." + ;; ─ n controlled add-subtracts on offset slices of wide ─ + ;; wide[k..k+n+1) — when k=0, wide[0]=low, wide[1..n+1)=tmp-ext[0..n). + ;; When k>=1, wide[k..k+n+1) sits entirely in tmp-ext[k-1..k+n). + ;; So we split: k=0 uses [low ++ tmp-ext[0..n)] as the slice, + ;; k>=1 uses tmp-ext[k-1..k+n) directly. + (let loop ((k 0)) + (when (< k n) + (cond + ((= k 0) + ;; Slice = [low(idx low-idx) ++ tmp-ext[0..n)]. We can't represent + ;; that as a single offset register, so we hand-code: copy x into + ;; xext, condition-flip, then run a SPECIAL cuccaro that uses + ;; low at bit 0 and tmp-ext at bits 1..n+1. Easier alternative: + ;; allocate a fresh (n+1)-wide buffer "wide0" that is + ;; pre-correlated to [low, tmp-ext[0..n)] via CX, run the slice + ;; add into wide0, then uncorrelate. But that re-introduces the + ;; aliasing problem. + ;; + ;; Cleanest fix: implement controlled-add-subtract to take a + ;; CALLBACK or two-register slice spec. Even simpler: at k=0, + ;; since low starts |0>, the slice is [|0>, tmp-ext[0..n)] — i.e. + ;; treat the slice as tmp-ext[0..n) padded with low at TOP. But + ;; Litinski needs low at the BOTTOM of the slice. + ;; + ;; Workaround: split the k=0 step into two: first do a + ;; controlled-add-subtract on the LOW bit (low alone, x[0] only), + ;; then handle bits 1..n+1 via the regular tmp-ext slice. + ;; That breaks the algorithm — the carries chain through. + ;; + ;; Real fix: use a JOINT cuccaro across (low, tmp-ext[0..n)). + ;; Implement schoolbook-row-k0! inline using offset CX/MAJ ops + ;; that explicitly reference low at index 0 and tmp-ext at + ;; indices 0..n-1 (treated as positions 1..n of the slice). + (schoolbook-row-k0! c x-reg n + y-reg k + low-reg low-idx + tmp-ext-reg + xext-reg cin-reg cin-idx)) + (else + ;; Slice lives entirely in tmp-ext at offset (k-1), width n+1. + (controlled-add-subtract-slice! c x-reg n + tmp-ext-reg (- k 1) + y-reg k + xext-reg cin-reg cin-idx))) + (loop (+ k 1)))) + ;; ─ Correction 1: wide[n..2n+1) += 2^0 * (y + 1), via cuccaro-add of + ;; y_ext = y ++ pad(=0) with c_in=1. wide[n..2n+1) = tmp-ext[n-1..2n). + ;; Set cin=1 via X, run cuccaro-add-offset over (n+1) bits, X cin back. + (gate-x! c cin-reg cin-idx) + (cuccaro-add-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg cin-reg cin-idx + const-tmp-reg) + (gate-x! c cin-reg cin-idx) + ;; ─ Correction 2: wide[2n] ^= 1 → tmp-ext[2n-1] ^= 1. + (gate-x! c tmp-ext-reg (- (* 2 n) 1)) + ;; ─ Correction 3: -x over the FULL (2n+1)-bit wide. Hand-code as a + ;; cuccaro-sub joint over [low ++ tmp-ext] with x at low bits, zeros + ;; above. We use const-tmp-reg padded with zeros as a (2n+1)-wide + ;; source... but it's only n+1 wide. + ;; + ;; Simpler: -x is just n bits of x at the bottom of wide. The high + ;; bits beyond x's range are zero. cuccaro-sub on a width-(2n+1) + ;; source where bits n..2n are |0> still works (zero high bits are a + ;; noop for MAJ/UMA — they just propagate the carry). + ;; + ;; We don't actually need extra register width: emit a "sub x into + ;; wide" routine that walks bits 0..n of x and bits n..2n+1 of wide + ;; as |0> source bits (no gate needed — they have no effect since the + ;; MAJ/UMA cells with x_high=0 reduce to identity on the wide bit). + ;; + ;; Actually that's still wrong — the carry chain still propagates + ;; through high bits. We need an honest cuccaro-sub with the full + ;; width. Use a TEMP (2n+1)-wide source register: alloc xfull, copy + ;; x into xfull[0..n), run cuccaro-sub-offset of xfull into wide, + ;; uncopy x. But alloc inside is fine. + (sub-x-from-wide! c x-reg n low-reg low-idx tmp-ext-reg cin-reg cin-idx) + ;; ─ Correction 4: wide[n..2n+1) += 2^0 * x, via cuccaro-add of x_ext + ;; (x ++ pad(=0)) with c_in=0. wide[n..2n+1) = tmp-ext[n-1..2n). + (cuccaro-add-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg cin-reg cin-idx + const-tmp-reg)) + +;;; ── helpers used by schoolbook-mul-into-addsub! ────────────── + +(define (schoolbook-row-k0! c x-reg n y-reg y-idx + low-reg low-idx tmp-ext-reg + xext-reg cin-reg cin-idx) + "k=0 row of Litinski: controlled-add-subtract on slice + [low ++ tmp-ext[0..n)] of width n+1, controlled on y[y-idx]. + We need a Cuccaro-add over a JOINT register (low at bit 0, tmp-ext + at bits 1..n). Emit inline using MAJ/UMA primitives with explicit + bit refs." + ;; xext = ctrl ? ~x[0..n) : x[0..n) + ;; cin = ctrl ? 1 : 0 + ;; Then cuccaro-add of xext into wide (treating wide[0]=low, wide[1..n+1)=tmp-ext[0..n)) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1)))) + (gate-x! c y-reg y-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c y-reg y-idx xext-reg k) + (loop (+ k 1)))) + (gate-cx! c y-reg y-idx cin-reg cin-idx) + ;; Joint cuccaro-add: source xext (n+1 wide, all in xext-reg), target + ;; "wide" where wide[0]=(low,low-idx), wide[i+1]=(tmp-ext-reg, i) for i in 0..n-1. + ;; Use a Cuccaro that selects target bits via a small switch. + (cuccaro-add-joint! c xext-reg 0 + low-reg low-idx tmp-ext-reg 0 + cin-reg cin-idx (+ n 1)) + (gate-cx! c y-reg y-idx cin-reg cin-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c y-reg y-idx xext-reg k) + (loop (+ k 1)))) + (gate-x! c y-reg y-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1))))) + +;;; Cuccaro-add where the ACCUMULATOR spans two registers: bit 0 lives +;;; at (low-reg, low-idx), bits 1..n-1 live at (mid-reg, mid-off..mid-off+n-2). +;;; Source register has width n, contiguous in src-reg at offset src-off. + +(define (joint-acc-ref low-reg low-idx mid-reg mid-off i) + "Return (reg idx) for bit i of the joint accumulator." + (if (= i 0) + (list low-reg low-idx) + (list mid-reg (+ mid-off (- i 1))))) + +(define (cuccaro-add-joint! c src-reg src-off + low-reg low-idx mid-reg mid-off + cin-reg cin-idx n) + "acc[0..n) := acc[0..n) + src[src-off..src-off+n), where acc[0]=(low,low-idx) + and acc[i]=(mid-reg, mid-off+i-1) for i>=1. n>=1. + When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path." + (cond + ((= n 1) + (gate-cx! c cin-reg cin-idx low-reg low-idx) + (gate-cx! c src-reg src-off low-reg low-idx)) + ((and *cas-borrowed-carries-reg* + (> *cas-borrowed-carries-width* 0) + (<= (- n 1) *cas-borrowed-carries-width*)) + (cuccaro-add-joint-fast-borrowed! c src-reg src-off + low-reg low-idx mid-reg mid-off + cin-reg cin-idx n + *cas-borrowed-carries-reg* + *cas-borrowed-carries-offset* + (cas-alloc-bit-base! n))) + (else + ;; MAJ(cin, acc[0], src[0]) — acc[0] = (low, low-idx) + (maj! c cin-reg cin-idx low-reg low-idx src-reg src-off) + (let loop ((i 1)) + (when (< i (- n 1)) + ;; MAJ(src[i-1], acc[i], src[i]) + (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i))) + (maj! c src-reg (+ src-off (- i 1)) + (car acc-i) (car (cdr acc-i)) + src-reg (+ src-off i))) + (loop (+ i 1)))) + ;; Final sum bit: acc[n-1] = (mid, mid-off+n-2) since n>=2 + (let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1)))) + (gate-cx! c src-reg (+ src-off (- n 2)) + (car acc-top) (car (cdr acc-top))) + (gate-cx! c src-reg (+ src-off (- n 1)) + (car acc-top) (car (cdr acc-top)))) + ;; Reverse UMA sweep + (let loop ((i (- n 2))) + (when (>= i 1) + (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i))) + (uma! c src-reg (+ src-off (- i 1)) + (car acc-i) (car (cdr acc-i)) + src-reg (+ src-off i))) + (loop (- i 1)))) + (uma! c cin-reg cin-idx low-reg low-idx src-reg src-off)))) + +(define (cuccaro-sub-joint! c src-reg src-off + low-reg low-idx mid-reg mid-off + cin-reg cin-idx n) + "Inverse of cuccaro-add-joint!. + When *cas-borrowed-carries-reg* set, dispatches to HMR uncompute path." + (cond + ((= n 1) + (gate-cx! c src-reg src-off low-reg low-idx) + (gate-cx! c cin-reg cin-idx low-reg low-idx)) + ((and *cas-borrowed-carries-reg* + (> *cas-borrowed-carries-width* 0) + (<= (- n 1) *cas-borrowed-carries-width*)) + (cuccaro-sub-joint-fast-borrowed! c src-reg src-off + low-reg low-idx mid-reg mid-off + cin-reg cin-idx n + *cas-borrowed-carries-reg* + *cas-borrowed-carries-offset* + (cas-alloc-bit-base! n))) + (else + (inv-uma! c cin-reg cin-idx low-reg low-idx src-reg src-off) + (let loop ((i 1)) + (when (< i (- n 1)) + (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i))) + (inv-uma! c src-reg (+ src-off (- i 1)) + (car acc-i) (car (cdr acc-i)) + src-reg (+ src-off i))) + (loop (+ i 1)))) + (let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1)))) + (gate-cx! c src-reg (+ src-off (- n 1)) + (car acc-top) (car (cdr acc-top))) + (gate-cx! c src-reg (+ src-off (- n 2)) + (car acc-top) (car (cdr acc-top)))) + (let loop ((i (- n 2))) + (when (>= i 1) + (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i))) + (inv-maj! c src-reg (+ src-off (- i 1)) + (car acc-i) (car (cdr acc-i)) + src-reg (+ src-off i))) + (loop (- i 1)))) + (inv-maj! c cin-reg cin-idx low-reg low-idx src-reg src-off)))) + +;;; ── cuccaro-add/sub-joint-fast-borrowed! — HMR uncompute, joint acc ─ +;;; +;;; Port of HEAD's cuccaro_add_fast pattern to the JOINT accumulator +;;; layout used by schoolbook-row-k0! + sub-x-from-wide!. acc[0] lives +;;; at (low-reg, low-idx); acc[i] for i>=1 lives at (mid-reg, mid-off+i-1). +;;; Source register is contiguous src-reg[src-off..src-off+n). +;;; +;;; Same MAJ-forward / HMR-backward gate sequence as +;;; cuccaro-add-offset-fast-borrowed! (mod-arith.lsp:651) — every acc[i] +;;; reference is translated through joint-acc-ref. src/cin indexing +;;; matches the offset variant exactly (contiguous source). +;;; +;;; Pre: carries-reg[carries-offset..carries-offset+n-2) must be |0> on entry. +;;; Post: carries-reg returns to |0>; src-reg + cin-reg unchanged; +;;; joint acc[0..n) := (acc + src) mod 2^n. +;;; bit-base..bit-base+n-2 are the classical-bit IDs used by HMR uncompute. + +(define (cuccaro-add-joint-fast-borrowed! c src-reg src-off + low-reg low-idx mid-reg mid-off + cin-reg cin-idx n + carries-reg carries-offset + bit-base) + "Joint-acc + borrowed-carries port of cuccaro-add-fast-borrowed!. + acc[0]=(low,low-idx); acc[i>=1]=(mid-reg, mid-off+i-1)." + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c cin-reg cin-idx low-reg low-idx) + (gate-cx! c src-reg src-off low-reg low-idx)) + (else + ;; Forward step i=0: acc[0] = (low, low-idx); src[0]; cin + (gate-cx! c src-reg src-off low-reg low-idx) + (gate-cx! c src-reg src-off cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx low-reg low-idx + carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset src-reg src-off) + ;; Forward steps i=1..n-2: acc[i] = (mid-reg, mid-off+i-1) + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i))) + (gate-cx! c src-reg (+ src-off i) + (car acc-i) (car (cdr acc-i))) + (gate-cx! c src-reg (+ src-off i) src-reg (+ src-off (- i 1))) + (gate-ccx! c src-reg (+ src-off (- i 1)) + (car acc-i) (car (cdr acc-i)) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) + src-reg (+ src-off i))) + (loop-fwd (+ i 1)))) + ;; Final sum bit: acc[n-1] = (mid, mid-off+n-2) for n>=2 + (let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1)))) + (gate-cx! c src-reg (+ src-off (- n 2)) + (car acc-top) (car (cdr acc-top))) + (gate-cx! c src-reg (+ src-off (- n 1)) + (car acc-top) (car (cdr acc-top)))) + ;; Backward HMR uncompute, i = n-2..1 + (let loop-back ((i (- n 2))) + (when (>= i 1) + (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i))) + (gate-cx! c carries-reg (+ carries-offset i) + src-reg (+ src-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) + (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c src-reg (+ src-off (- i 1)) + (car acc-i) (car (cdr acc-i))) + (gate-pop-cond! c) + (gate-cx! c src-reg (+ src-off i) src-reg (+ src-off (- i 1))) + (gate-cx! c src-reg (+ src-off (- i 1)) + (car acc-i) (car (cdr acc-i)))) + (loop-back (- i 1)))) + ;; Backward HMR i=0: acc[0] = (low, low-idx) + (gate-cx! c carries-reg carries-offset src-reg src-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx low-reg low-idx) + (gate-pop-cond! c) + (gate-cx! c src-reg src-off cin-reg cin-idx) + (gate-cx! c cin-reg cin-idx low-reg low-idx)))) + +(define (cuccaro-sub-joint-fast-borrowed! c src-reg src-off + low-reg low-idx mid-reg mid-off + cin-reg cin-idx n + carries-reg carries-offset + bit-base) + "Joint-acc + borrowed-carries port of cuccaro-sub-fast-borrowed!. + acc[0..n) := (acc - src - cin) mod 2^n." + (cond + ((= n 0) #t) + ((= n 1) + (gate-cx! c src-reg src-off low-reg low-idx) + (gate-cx! c cin-reg cin-idx low-reg low-idx)) + (else + ;; Forward inv-UMA-like at i=0 + (gate-cx! c cin-reg cin-idx low-reg low-idx) + (gate-cx! c src-reg src-off cin-reg cin-idx) + (gate-ccx! c cin-reg cin-idx low-reg low-idx + carries-reg carries-offset) + (gate-cx! c carries-reg carries-offset src-reg src-off) + ;; Forward steps i=1..n-2 + (let loop-fwd ((i 1)) + (when (< i (- n 1)) + (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i))) + (gate-cx! c src-reg (+ src-off (- i 1)) + (car acc-i) (car (cdr acc-i))) + (gate-cx! c src-reg (+ src-off i) src-reg (+ src-off (- i 1))) + (gate-ccx! c src-reg (+ src-off (- i 1)) + (car acc-i) (car (cdr acc-i)) + carries-reg (+ carries-offset i)) + (gate-cx! c carries-reg (+ carries-offset i) + src-reg (+ src-off i))) + (loop-fwd (+ i 1)))) + ;; Final sum bit — sub order swaps the two CXs + (let ((acc-top (joint-acc-ref low-reg low-idx mid-reg mid-off (- n 1)))) + (gate-cx! c src-reg (+ src-off (- n 1)) + (car acc-top) (car (cdr acc-top))) + (gate-cx! c src-reg (+ src-off (- n 2)) + (car acc-top) (car (cdr acc-top)))) + ;; Backward HMR uncompute, i = n-2..1 + (let loop-back ((i (- n 2))) + (when (>= i 1) + (let ((acc-i (joint-acc-ref low-reg low-idx mid-reg mid-off i))) + (gate-cx! c carries-reg (+ carries-offset i) + src-reg (+ src-off i)) + (gate-hmr! c carries-reg (+ carries-offset i) + (+ bit-base i)) + (gate-push-cond! c (+ bit-base i)) + (gate-cz! c src-reg (+ src-off (- i 1)) + (car acc-i) (car (cdr acc-i))) + (gate-pop-cond! c) + (gate-cx! c src-reg (+ src-off i) src-reg (+ src-off (- i 1))) + (gate-cx! c src-reg (+ src-off i) + (car acc-i) (car (cdr acc-i)))) + (loop-back (- i 1)))) + ;; Backward HMR i=0 + (gate-cx! c carries-reg carries-offset src-reg src-off) + (gate-hmr! c carries-reg carries-offset bit-base) + (gate-push-cond! c bit-base) + (gate-cz! c cin-reg cin-idx low-reg low-idx) + (gate-pop-cond! c) + (gate-cx! c src-reg src-off cin-reg cin-idx) + (gate-cx! c src-reg src-off low-reg low-idx)))) + +;;; Correction 1 helper: wide[n..2n+1) += y_ext where y_ext = y at bits +;;; [0..n) and pad(=0) at bit n. We need to cuccaro-add the y bits into +;;; a (n+1)-wide slice of wide at offset n. wide[n] = tmp-ext[n-1]. +;;; wide[n+1..2n+1) = tmp-ext[n..2n). +;;; +;;; This is the SAME joint accumulator pattern: target bit 0 = (tmp-ext, +;;; n-1), target bits 1..n = (tmp-ext, n..2n-1). Adjacent indices — +;;; really a SINGLE register slice tmp-ext[n-1..2n). +;;; +;;; Source y_ext: we need n+1 bits where y_ext[0..n) = y and y_ext[n] = 0. +;;; We use const-tmp-reg (n+1 wide |0>) as y_ext: copy y into bits [0..n), +;;; run cuccaro-add-offset of const-tmp into tmp-ext at offset n-1 width +;;; n+1, then uncopy y. + +(define (cuccaro-add-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg + cin-reg cin-idx const-tmp-reg) + "wide[n..2n+1) += y_ext with c_in present. + wide[n..2n+1) = tmp-ext[n-1..2n)." + ;; Copy y → const-tmp low n bits. const-tmp[n] stays |0> = pad. + (let loop ((k 0)) + (when (< k n) + (gate-cx! c y-reg k const-tmp-reg k) + (loop (+ k 1)))) + ;; cuccaro-add at width n+1 into tmp-ext at offset n-1. + (cuccaro-add-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1) + cin-reg cin-idx (+ n 1)) + ;; Uncopy. + (let loop ((k 0)) + (when (< k n) + (gate-cx! c y-reg k const-tmp-reg k) + (loop (+ k 1))))) + +(define (cuccaro-sub-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg + cin-reg cin-idx const-tmp-reg) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c y-reg k const-tmp-reg k) + (loop (+ k 1)))) + (cuccaro-sub-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1) + cin-reg cin-idx (+ n 1)) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c y-reg k const-tmp-reg k) + (loop (+ k 1))))) + +(define (cuccaro-add-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg + cin-reg cin-idx const-tmp-reg) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k const-tmp-reg k) + (loop (+ k 1)))) + (cuccaro-add-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1) + cin-reg cin-idx (+ n 1)) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k const-tmp-reg k) + (loop (+ k 1))))) + +(define (cuccaro-sub-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg + cin-reg cin-idx const-tmp-reg) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k const-tmp-reg k) + (loop (+ k 1)))) + (cuccaro-sub-offset! c const-tmp-reg 0 tmp-ext-reg (- n 1) + cin-reg cin-idx (+ n 1)) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k const-tmp-reg k) + (loop (+ k 1))))) + +;;; Correction 3 helper: wide -= x, where wide has width 2n+1 ([low ++ tmp-ext]) +;;; and x is at x-reg[0..n). x's high (2n+1-n)=n+1 bits are zero (we pad). +;;; +;;; Use a JOINT cuccaro-sub over the full wide. Source: const-tmp at low +;;; n bits (loaded from x) zero-padded above. But const-tmp is only n+1 +;;; wide — we need 2n+1 wide source. We allocate xfull internally. +;;; +;;; *sub-x-from-wide-cas-fast* — sweep-027 opt-in flag. When BOTH +;;; *cuccaro-callers-fast* AND this flag are set, widen sb-xfull to +;;; 4n+1 and dispatch joint via cas-borrowed. Disabled by default +;;; (sweep-027 verdict: knife-edge ROI, +10%% worst-case score). +;;; ALLOC width 4n+1 = 1025 at production hits the n=512 ancilla cap +;;; if cap isnt raised — keep off unless cap is also raised. + +(define *sub-x-from-wide-cas-fast* #f) + +;;; *sub-x-from-wide-host-alloc* — sweep-036 opt-in flag (allocator +;;; surgery). When set, mod-mul-solinas! / mod-mul-solinas-sub! allocate +;;; sb-xfull at Stage-0 (TOP of their scratch suite, BEFORE sb-tmp-ext / +;;; sb-low / sb-xext / sb-const-tmp) instead of letting sub-x-from-wide! +;;; / add-x-into-wide! allocate it internally on each call. The hoisted +;;; alloc lands at the lowest free 513-wide base inside the mod-mul +;;; scope; sub-x-from-wide! / add-x-into-wide! consult *host-sb-xfull-reg* +;;; & skip their internal alloc when that variable is bound. ZERO Toffoli +;;; delta — same sb-xfull contents, same gate sequence. The opt-in is a +;;; pure register-lifetime re-order: it removes the deep-nested late +;;; allocation that landed sb-xfull on top of the dgcd-host floor. +;;; +;;; Predicted peak qubits change: sweep-035 baseline 5,024 → ~4,510 +;;; (−10.2 %) per allocator-replay subagent (runs/lumbda-sweep-032 +;;; ALLOCATOR-REPORT-sweep030.md temporal-overlap candidate #2). +;;; +;;; When flag off & *host-sb-xfull-reg* #f, both helpers fall through +;;; their old alloc-internal path — byte-identical to sweep-035. + +(define *sub-x-from-wide-host-alloc* #f) + +;;; Dynamic variable bound by mod-mul-solinas! / mod-mul-solinas-sub! +;;; when *sub-x-from-wide-host-alloc* is on: holds the host-allocated +;;; sb-xfull register name, communicated to sub-x-from-wide! / +;;; add-x-into-wide! without changing their signatures. Cleared to #f +;;; after the Stage-3 inverse pass so subsequent mod-mul calls outside +;;; the host scope alloc internally again. + +(define *host-sb-xfull-reg* #f) + +;;; sweep-027: when *cuccaro-callers-fast* is set, widen sb-xfull from +;;; 2n+1 → 4n+1 so the top 2n bits can serve as borrowed carries for the +;;; JOINT fast-borrowed dispatch path: +;;; +;;; sb-xfull[0..n) = x data (Stage-1 load) +;;; sb-xfull[n..2n+1) = source pad (touched by cuccaro as |0> bits) +;;; sb-xfull[2n+1..4n+1) = HMR carries pad (clean |0> on entry/exit) +;;; +;;; Width-N=2n+1 joint fast-borrowed consumes N-1 = 2n carries lanes, +;;; which exactly fits sb-xfull[2n+1..4n+1). Bit-base 300000 disjoint +;;; from mod-solinas' 200000 reservation (which covers up to n+1 bits). +;;; Saves (N-1)-N/2 ≈ N-1 = 2n Toffoli per call via HMR uncompute; +;;; cost is +2n qubits in sb-xfull's transient allocation. + +(define (sub-x-from-wide! c x-reg n low-reg low-idx tmp-ext-reg + cin-reg cin-idx) + "wide := wide - x, where wide = [low ++ tmp-ext] (2n+1 bits) and x is + at x-reg[0..n). High bits of x_padded are 0. Uses internal xfull + ancilla (alloc'd here; widened to 4n+1 under *cuccaro-callers-fast* + to host the JOINT fast-borrowed carries). + + When *host-sb-xfull-reg* is bound (sweep-036 opt-in), the caller + (mod-mul-solinas!) has pre-allocated sb-xfull at outer scope; skip + internal alloc/free & use the hosted register name." + (let* ((use-fast? (and *cuccaro-callers-fast* *sub-x-from-wide-cas-fast*)) + (joint-width (+ (* 2 n) 1)) ; N = 2n+1 + (carries-need (- joint-width 1)) ; N-1 = 2n + (xfull-width (cond (use-fast? (+ joint-width carries-need)) + (else joint-width))) + (host-reg *host-sb-xfull-reg*) + (xfull-name (cond (host-reg host-reg) + (else (quote sb-xfull))))) + ;; Allocate xfull (xfull-width bits |0>) — unless hosted by caller. + (when (not host-reg) + (alloc! c xfull-name xfull-width)) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xfull-name k) + (loop (+ k 1)))) + ;; Configure cas-borrowed for joint dispatch when in fast mode. + (cond + (use-fast? + (let ((saved-reg *cas-borrowed-carries-reg*) + (saved-off *cas-borrowed-carries-offset*) + (saved-base *cas-borrowed-bit-base*) + (saved-width *cas-borrowed-carries-width*)) + (set! *cas-borrowed-carries-reg* xfull-name) + (set! *cas-borrowed-carries-offset* joint-width) + (set! *cas-borrowed-bit-base* 300000) + (set! *cas-borrowed-carries-width* carries-need) + (cuccaro-sub-joint! c xfull-name 0 + low-reg low-idx tmp-ext-reg 0 + cin-reg cin-idx joint-width) + (set! *cas-borrowed-carries-reg* saved-reg) + (set! *cas-borrowed-carries-offset* saved-off) + (set! *cas-borrowed-bit-base* saved-base) + (set! *cas-borrowed-carries-width* saved-width))) + (else + (cuccaro-sub-joint! c xfull-name 0 + low-reg low-idx tmp-ext-reg 0 + cin-reg cin-idx joint-width))) + ;; Uncopy x. + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xfull-name k) + (loop (+ k 1)))) + (when (not host-reg) + (free! c xfull-name)))) + +(define (add-x-into-wide! c x-reg n low-reg low-idx tmp-ext-reg + cin-reg cin-idx) + "Inverse of sub-x-from-wide!: wide += x over full 2n+1 bits. + sb-xfull widened to 4n+1 under *cuccaro-callers-fast* to host + the JOINT fast-borrowed carries pad above the source range. + + When *host-sb-xfull-reg* is bound (sweep-036 opt-in), use the hosted + register instead of allocating/freeing internally." + (let* ((use-fast? (and *cuccaro-callers-fast* *sub-x-from-wide-cas-fast*)) + (joint-width (+ (* 2 n) 1)) + (carries-need (- joint-width 1)) + (xfull-width (cond (use-fast? (+ joint-width carries-need)) + (else joint-width))) + (host-reg *host-sb-xfull-reg*) + (xfull-name (cond (host-reg host-reg) + (else (quote sb-xfull))))) + (when (not host-reg) + (alloc! c xfull-name xfull-width)) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xfull-name k) + (loop (+ k 1)))) + (cond + (use-fast? + (let ((saved-reg *cas-borrowed-carries-reg*) + (saved-off *cas-borrowed-carries-offset*) + (saved-base *cas-borrowed-bit-base*) + (saved-width *cas-borrowed-carries-width*)) + (set! *cas-borrowed-carries-reg* xfull-name) + (set! *cas-borrowed-carries-offset* joint-width) + (set! *cas-borrowed-bit-base* 300000) + (set! *cas-borrowed-carries-width* carries-need) + (cuccaro-add-joint! c xfull-name 0 + low-reg low-idx tmp-ext-reg 0 + cin-reg cin-idx joint-width) + (set! *cas-borrowed-carries-reg* saved-reg) + (set! *cas-borrowed-carries-offset* saved-off) + (set! *cas-borrowed-bit-base* saved-base) + (set! *cas-borrowed-carries-width* saved-width))) + (else + (cuccaro-add-joint! c xfull-name 0 + low-reg low-idx tmp-ext-reg 0 + cin-reg cin-idx joint-width))) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xfull-name k) + (loop (+ k 1)))) + (when (not host-reg) + (free! c xfull-name)))) + +;;; Inverse of schoolbook-mul-into-addsub!: undo each correction then +;;; the loop, gate-by-gate inverted. Self-inverse steps (X) re-emit. + +(define (schoolbook-mul-into-addsub-inverse! c x-reg y-reg n + low-reg low-idx + tmp-ext-reg + xext-reg cin-reg cin-idx + const-tmp-reg) + ;; Reverse correction 4: cuccaro-sub of x_ext at high half. + (cuccaro-sub-x-ext-into-tmp-hi! c x-reg n tmp-ext-reg cin-reg cin-idx + const-tmp-reg) + ;; Reverse correction 3: add x back into wide. + (add-x-into-wide! c x-reg n low-reg low-idx tmp-ext-reg cin-reg cin-idx) + ;; Reverse correction 2: re-XOR top bit (self-inverse). + (gate-x! c tmp-ext-reg (- (* 2 n) 1)) + ;; Reverse correction 1: cuccaro-sub of y_ext with cin=1. + (gate-x! c cin-reg cin-idx) + (cuccaro-sub-y-ext-into-tmp-hi! c y-reg n tmp-ext-reg cin-reg cin-idx + const-tmp-reg) + (gate-x! c cin-reg cin-idx) + ;; Reverse the main loop (k from n-1 down to 0). + (let loop ((k (- n 1))) + (when (>= k 0) + (cond + ((= k 0) + (schoolbook-row-k0-inverse! c x-reg n + y-reg k + low-reg low-idx + tmp-ext-reg + xext-reg cin-reg cin-idx)) + (else + (controlled-add-subtract-slice-inverse! c x-reg n + tmp-ext-reg (- k 1) + y-reg k + xext-reg cin-reg cin-idx))) + (loop (- k 1))))) + +(define (schoolbook-row-k0-inverse! c x-reg n y-reg y-idx + low-reg low-idx tmp-ext-reg + xext-reg cin-reg cin-idx) + "Inverse of schoolbook-row-k0!." + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1)))) + (gate-x! c y-reg y-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c y-reg y-idx xext-reg k) + (loop (+ k 1)))) + (gate-cx! c y-reg y-idx cin-reg cin-idx) + (cuccaro-sub-joint! c xext-reg 0 + low-reg low-idx tmp-ext-reg 0 + cin-reg cin-idx (+ n 1)) + (gate-cx! c y-reg y-idx cin-reg cin-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c y-reg y-idx xext-reg k) + (loop (+ k 1)))) + (gate-x! c y-reg y-idx) + (let loop ((k 0)) + (when (< k n) + (gate-cx! c x-reg k xext-reg k) + (loop (+ k 1))))) + +;;; ── mod-mul! — Litinski wide schoolbook + Solinas-style reduction ─ +;;; +;;; Calling convention: +;;; a-reg, b-reg, out-reg : (n+1)-wide; top bit must be |0> on entry +;;; (we operate on low n bits only). +;;; a-reg, b-reg preserved; out-reg ends with +;;; (a*b) mod p. +;;; cin-reg, cin-idx : 1 bit |0> in/out (mod-add c_in) +;;; tmp-reg : (n+1)-wide |0> in/out — mod-add's inner +;;; constant-loading scratch. +;;; flag-reg, flag-idx : 1 bit |0> in/out (mod-add flag) +;;; red-tmp-reg : (n+1)-wide |0> in/out — used in Stage 2 to +;;; load 2^k mod p constants into a register +;;; before mod-add into out. +;;; +;;; Inside, mod-mul! allocates its own Litinski scratch: +;;; sb-tmp-ext (2n bits) the wide product accumulator +;;; sb-low (1 bit) wide[0] +;;; sb-xext (n+1 bits) controlled-add-subtract scratch +;;; sb-const-tmp (n+1 bits) correction-stage constant-loading scratch +;;; sb-xfull (2n+1 bits, alloc/free'd inside sub-x-from-wide!) + +;;; ── Solinas dispatch flag ───────────────────────────────────── +;;; +;;; When *mod-mul-use-solinas* is non-#f, mod-mul! and mod-mul-sub! +;;; dispatch into mod-mul-solinas! / mod-mul-solinas-sub! (defined in +;;; lumbda/mod-solinas.lsp — caller must load that file before flipping +;;; the flag). Caller-visible signatures and ancilla register names +;;; remain identical, so every consumer (mod-inv!, mod-square!, +;;; real-point-add!) inherits the speedup without code change. + +(define *mod-mul-use-solinas* #f) + +(define (mod-mul! c a-reg b-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg) + "out := (a * b) mod p. Litinski schoolbook + per-bit Solinas-style reduce. + See header for full calling convention. + + When *mod-mul-use-solinas* is non-#f, dispatch to mod-mul-solinas! + (mod-solinas.lsp must already be loaded)." + (cond + (*mod-mul-use-solinas* + (mod-mul-solinas! c a-reg b-reg out-reg n+1 p + (compute-c-expansion p (- n+1 1)) + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg)) + (else + (mod-mul-litinski! c a-reg b-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg)))) + +;;; ── mod-mul-from-zero! — caller-explicit out=|0> specialization ─── +;;; +;;; Port of HEAD's `mod_add_qq_fast_from_zero` lifted to the multiply +;;; entry boundary. Caller invokes this INSTEAD of mod-mul! when out-reg +;;; is provably |0> on entry (e.g. mod-square!'s freshly-alloc'd out, +;;; mod-inv-by Fermat ladder's r-next / b-next, point-add lam-reg before +;;; any accumulation). +;;; +;;; Saves n CCX per fresh-multiply when both +;;; *mod-mul-use-solinas* AND *mod-mul-from-zero-first-add* +;;; are #t. When *mod-mul-from-zero-first-add* off, byte-identical to +;;; mod-mul-solinas! (safe fallback). When *mod-mul-use-solinas* off, +;;; falls through to mod-mul-litinski! (no specialization yet for the +;;; Litinski path — Stage 2 dispatch shape differs). + +(define (mod-mul-from-zero! c a-reg b-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg) + "out := (a * b) mod p when out is |0> on entry. See mod-mul! header + for calling convention." + (cond + (*mod-mul-use-solinas* + (mod-mul-solinas-from-zero! c a-reg b-reg out-reg n+1 p + (compute-c-expansion p (- n+1 1)) + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg)) + (else + (mod-mul-litinski! c a-reg b-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg)))) + +(define (mod-mul-litinski! c a-reg b-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg) + "Original Litinski wide-schoolbook + per-bit Solinas reduce. Renamed + from mod-mul! so we can preserve the original code path for + regression testing while mod-mul! itself becomes the dispatcher." + (let ((n (- n+1 1))) + (cond + ((= n 0) #t) ; degenerate, nothing to do + (else + ;; ── Stage 0: alloc Litinski scratch ── + (alloc! c (quote sb-tmp-ext) (* 2 n)) + (alloc! c (quote sb-low) 1) + (alloc! c (quote sb-xext) (+ n 1)) + (alloc! c (quote sb-const-tmp) (+ n 1)) + ;; ── Stage 1: compute wide product sb-tmp-ext := a * b ── + (schoolbook-mul-into-addsub! c a-reg b-reg n + (quote sb-low) 0 + (quote sb-tmp-ext) + (quote sb-xext) + cin-reg cin-idx + (quote sb-const-tmp)) + ;; ── Stage 2: reduce sb-tmp-ext mod p into out ── + ;; For each bit k in [0, 2n): if sb-tmp-ext[k]=1 then + ;; out += (2^k mod p) mod p. + ;; Reversible via cload-const + mod-add + cunload-const, where the + ;; constant lives in red-tmp-reg (n+1 wide, top bit |0>). + (let loop ((k 0)) + (when (< k (* 2 n)) + (let ((c-k (modulo (expt 2 k) p))) + (when (> c-k 0) ; skip no-op constants + ;; Load c-k into red-tmp controlled on sb-tmp-ext[k]. + (cload-const! c (quote sb-tmp-ext) k red-tmp-reg n+1 c-k) + ;; Add red-tmp into out mod p. + (mod-add! c red-tmp-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + ;; Unload c-k. + (cunload-const! c (quote sb-tmp-ext) k red-tmp-reg n+1 c-k))) + (loop (+ k 1)))) + ;; ── Stage 3: uncompute sb-tmp-ext back to |0> ── + (schoolbook-mul-into-addsub-inverse! c a-reg b-reg n + (quote sb-low) 0 + (quote sb-tmp-ext) + (quote sb-xext) + cin-reg cin-idx + (quote sb-const-tmp)) + ;; ── Stage 4: free Litinski scratch ── + (free! c (quote sb-const-tmp)) + (free! c (quote sb-xext)) + (free! c (quote sb-low)) + (free! c (quote sb-tmp-ext)))))) + +;;; ── mod-double-inplace! — v := 2v mod p, (n+1)-wide register ── +;;; +;;; Mirrors upstream's mod_double_inplace at mod.rs:2769. +;;; +;;; Pattern (cost: O(n) gates): +;;; 1. Shift-left v by 1 via SWAP cascade. Caller's (n+1)-wide v-reg +;;; starts as [v_0 v_1 ... v_{n-1} 0]; after the cascade we have +;;; [0 v_0 v_1 ... v_{n-1}]. Now v-reg = T = 2 * v_orig in [0, 2p). +;;; 2. Add c = 2^n - p across the full (n+1) bits. Sum S = T + c. +;;; Top bit (idx n) of S is set iff T >= p. +;;; 3. flag := S[n] via CX. +;;; 4. csub c controlled on (NOT flag) — undoes the add when no reduction. +;;; 5. CX flag -> S[n] — clears the top bit when reduction needed. +;;; 6. Uncompute flag: T is even (= 2v), p is odd → after reduction v[0]=1; +;;; no reduction → v[0]=0. So flag == v[0]. CX v[0] -> flag clears. +;;; +;;; All ancillae (cin, tmp, flag) return to |0>. v-reg top bit returns to |0>. +;;; Caller-supplied ancillae: cin (1 bit), tmp (n+1 wide), flag (1 bit). +;;; +;;; Variant choice: in-place via swap cascade + Solinas-style fold. +;;; Chosen because it mirrors upstream byte-for-byte; alternative +;;; Bennett-style "double via mod-add of copy" requires a 2^{-1} mod p +;;; classical inversion AND a fresh ancilla — heavier than this one +;;; ovf-bit pattern in lumbda. See task spec §"variant choice". +;;; +;;; SWAP not in our gate set — implemented as 3 CX (a→b, b→a, a→b). + +(define (gate-swap! c a-reg a-idx b-reg b-idx) + "SWAP qubit a with b via three CXs. Self-inverse." + (gate-cx! c a-reg a-idx b-reg b-idx) + (gate-cx! c b-reg b-idx a-reg a-idx) + (gate-cx! c a-reg a-idx b-reg b-idx)) + +;;; ── pseudo-Mersenne mod-double (Schrottenloher 2026 Algorithm 7) ─ +;;; +;;; For pseudo-Mersenne primes p = 2^u - f with f << 2^u (secp256k1: u=256, +;;; f=2^32+977=4294968273, 33 bits) the entire add-const / csub-const / +;;; flag-uncompute dance collapses to a single controlled add of f over the +;;; LOW lsbs bits of v, controlled on the carry-out from the shift. +;;; +;;; Algorithm 7 (qarton special_mod_arithmetic.py:54-92): +;;; 1. shift v left by 1 (anc receives MSB carry-out) +;;; 2. cadd(anc, f, v[:lsbs]) — controlled add of f into low lsbs bits +;;; 3. cx(v[0], anc) — uncompute anc via parity +;;; +;;; Correctness lsbs = padding + bit_length(f). The cadd carry walks at most +;;; lsbs bits; if it would propagate further, the result is wrong. For +;;; uniform random v the failure probability is roughly 2^(-padding). Qarton +;;; uses padding=30 by default — same as Schrottenloher §4. +;;; +;;; Toffoli savings vs control: control mod-double-inplace! emits one +;;; add-const + one csub-const, both at full width (n+1). Each cuccaro-add +;;; over k bits costs 2(k-1) Toffoli (HEAD's HMR-borrowed variant: k-1). +;;; Pseudo-Mersenne emits ONE cadd-const at width lsbs only. Predicted +;;; Toffoli savings at secp256k1 width: ≈ 2 × (n+1 - lsbs) / (2(n+1)) ≈ +;;; (256 - 63) / 257 ≈ 75 % of mod-double Toffoli; mod-double itself sits +;;; at ~8 % of total (Schrottenloher Table 3) → predicted 5-10 % full-stack. + +(define *mod-double-use-pseudo-mersenne* #f) +;;; *mod-double-pseudo-mersenne-padding* — extra carry-safety bits beyond +;;; bit_length(f) for the controlled add. Larger padding → smaller flake +;;; probability ≈ 2^(-padding) but more Toffoli per call. Qarton + paper +;;; both use 30 by default. +(define *mod-double-pseudo-mersenne-padding* 30) + +;;; *windowed-mod-double-r* — sweep-windowed-mod-double-r dispatcher. +;;; When #t, mod-double-inplace! routes through mod-double-inplace- +;;; windowed! (HEAD modular.rs:417-419 windowed branch). Foundation for +;;; K=5 apply-phase split — HEAD's compressed.rs:1986-1999 + 2515 +;;; lean on the windowed form for the q1192 island. Default #f preserves +;;; byte-identity for every existing caller. Truncation flake +;;; probability ≈ 2^-(window+1) per call (window pulled from +;;; *windowed-mod-double-r-window*, default 8 matching HEAD). +;;; +;;; Composes with neither *mod-double-use-pseudo-mersenne* nor the +;;; alg-11 safe-band detector — the windowed path is its own dispatch +;;; branch (highest-priority) in mod-double-inplace!. +(define *windowed-mod-double-r* #f) +(define *windowed-mod-double-r-window* 8) + +(define (pmersenne-bit-length n) + "Number of bits to represent positive integer n (== Python's int.bit_length). + bit-length(0)=0, bit-length(1)=1, bit-length(2)=2, bit-length(3)=2, ..." + (let loop ((k 0) (m n)) + (if (= m 0) k (loop (+ k 1) (quotient m 2))))) + +(define (mod-double-inplace-pseudo-mersenne! + c v-reg n+1 p pmersenne-f + cin-reg cin-idx tmp-reg flag-reg flag-idx) + "Pseudo-Mersenne variant of mod-double-inplace!. Same calling convention + (v-reg (n+1) wide, cin/tmp/flag scratch); ignores flag-reg/flag-idx + (kept for signature compatibility with the dispatcher). + pmersenne-f = 2^n - p (must be > 0 and small)." + (let* ((n (- n+1 1)) + (f-bits (pmersenne-bit-length pmersenne-f)) + (padding *mod-double-pseudo-mersenne-padding*) + (lsbs (min n+1 (+ padding f-bits)))) + ;; (1) Shift-left v in place via SWAP cascade. + ;; End state: bit 0 = 0, bit i (i>=1) = v_orig[i-1], + ;; bit n = v_orig[n-1] = pseudo-Mersenne carry-out. + (let loop ((i n)) + (when (> i 0) + (gate-swap! c v-reg i v-reg (- i 1)) + (loop (- i 1)))) + ;; (2) cadd(anc=v[n], f, v[0..lsbs)) — controlled add of f into low bits. + ;; No aliasing concern: ctrl-idx = n, tgt-idx range = [0, lsbs) with + ;; lsbs < n+1, so ctrl bit never overlaps with cadd's target slice. + (cadd-const! c v-reg lsbs pmersenne-f + v-reg n cin-reg cin-idx tmp-reg) + ;; (3) Uncompute anc via parity: 2v is even, p is odd → after reduction + ;; v[0] = 1, no reduction → v[0] = 0. CX v[0] -> v[n] clears anc. + (gate-cx! c v-reg 0 v-reg n))) + +;;; ── mod-halve-inplace-direct-const-fast! ────────────────────────── +;;; +;;; Port of HEAD mod_halve_inplace_direct_const_fast +;;; (src/point_add/arith/modular.rs:753-765, commit 2dcf00d). Gate-level +;;; inverse of mod_double_inplace_direct_const_fast (sweep-030 PORTED +;;; in lumbda as mod-double-inplace-pseudo-mersenne!). Closes the open +;;; question sweep-030 RESULTS.md flagged + the mod-add-double-qb +;;; PORTED-WITH-GAP from sweep-mod-qb-adders. +;;; +;;; HEAD algorithm (5 steps): +;;; 1. alloc ovf qubit +;;; 2. cx(v[0], ovf) -- XOR LSB into ovf +;;; 3. csub_nbit_const_direct_fast(v, c, ovf) where c = 2^n - p +;;; 4. swap chain: for i in 0..n-1: swap(v[i], v[i+1]) (right rotate) +;;; 5. swap(v[n-1], ovf); free ovf -- ovf bit lands at v[n-1] +;;; +;;; This is the EXACT gate-level inverse of the direct-const double +;;; (HEAD line 408+): the double's pre-shift swap-chain becomes the +;;; halve's post-shift swap-chain; the double's cadd becomes the +;;; halve's csub; the double's parity-uncompute becomes the halve's +;;; parity-cx-INTO-ovf at the start. +;;; +;;; Substrate status: ADDITIVE. No lumbda caller dispatches through +;;; this primitive yet. mod-add-double-qb (sweep-mod-qb-adders) can +;;; route through this once a follow-on sweep adds the dispatcher +;;; flag (analog of HEAD's KAL_DIRECT_CONST_HALVE / direct_const_ +;;; walks_enabled). +;;; +;;; Caller supplies the 'mod-halve-anc qubit + carries lane via cin/ +;;; tmp/flag (HEAD allocs inline; lumbda style routes through args). + +;;; ── mod-double-inplace-direct-const-fast! — sweep-sq-lowq-shift22 ── +;;; +;;; HEAD modular.rs:414. Mirror of mod-halve-inplace-direct-const-fast! +;;; with cadd direction. Uses cadd-nbit-const-direct-fast! (PORTED in +;;; sweep-cadd-csub-direct-fast) for the Solinas correction. + +(define (mod-double-inplace-direct-const-fast! + c v-reg n+1 p pmersenne-f + cin-reg cin-idx tmp-reg flag-reg flag-idx) + "Port of HEAD mod_double_inplace_direct_const_fast (modular.rs:414). + v-reg := 2*v mod p (in place). v-reg is (n+1)-wide; v in low n bits, + v[n] = ovf at |0> on entry + restored on exit. pmersenne-f = 2^n - p." + (let* ((n (- n+1 1)) + (c-const pmersenne-f)) + ;; (1) swap(v[n-1], v[n]). + (gate-swap! c v-reg (- n 1) v-reg n) + ;; (2) Right-rotate the n low bits via reverse swap chain. + (let loop ((i (- n 2))) + (when (>= i 0) + (gate-swap! c v-reg i v-reg (+ i 1)) + (loop (- i 1)))) + ;; (3) cadd-nbit-const-direct-fast! ctrl=v[n] (ovf) into v[0..n]. + (cadd-nbit-const-direct-fast! + c v-reg n c-const v-reg n tmp-reg (* 4 n+1)) + ;; (4) Parity CX: v[0] XOR into v[n] (clears ovf). + (gate-cx! c v-reg 0 v-reg n))) + +;;; ── mod-double-inplace-windowed! — sweep-windowed-mod-double-r ── +;;; +;;; Port of HEAD `mod_double_inplace_fast_with_dirty` +;;; (modular.rs:398-444), windowed branch (lines 417-419 — fires when +;;; `double_carry_trunc_window()` returns `Some(w)` i.e. env var +;;; `KAL_DOUBLE_CARRY_TRUNC_W=w`). HEAD's K=5 apply-phase ipmul + +;;; quotient bodies (compressed.rs:1986-1999 + 2515) lean on this +;;; windowed form for the q1192 island; the apply-phase callsite +;;; allocates an `ovf` qubit, swaps the top bit out, right-rotates the +;;; low n bits, then runs ONE truncated cadd against ctrl=ovf instead +;;; of the standard add-const + csub-const + flag-uncompute pair. +;;; +;;; Structural shape vs `mod-double-inplace-direct-const-fast!`: +;;; +;;; • direct-const-fast emits a FULL-width `cadd-nbit-const-direct-fast!` +;;; (no carry-tail truncation; exact for any v). +;;; • windowed emits `cadd-nbit-const-direct-trunc-fast!` with carry +;;; ripple stopped `window` bits past `highest_set_bit(c)`. +;;; For secp256k1, c = 2^32 + 977 has highest-bit 32; window=8 stops +;;; the ripple at bit 40 — saves ~(n - 40) carry maj-recurrence +;;; CCXs + the matching backward HMR sweep per call. Per-call +;;; Toffoli drops from ~2(n-1) to ~2*(highest_set_bit(c) + w). +;;; +;;; Flake probability: ~2^-(window+1) per call. At window=8 that's +;;; ~2^-9 ≈ 0.2 %. Production cells stack the apply-phase fold's same +;;; window so forward + reverse use matching truncation; mismatch only +;;; manifests when the carry-tail propagates through `window + 1` +;;; consecutive 1-bits in the running accumulator above bit 32 — the +;;; "exact-unless-rare-input" regime documented in HEAD's +;;; cadd_nbit_const_direct_trunc_fast docstring (const_arith.rs:526). +;;; +;;; Calling convention matches `mod-double-inplace!`: +;;; v-reg : (n+1)-wide; v in low n bits, bit n at |0> in/out. +;;; p : prime; classical. +;;; pmersenne-f : 2^n - p (HEAD's `c`). Caller computes once. +;;; tmp-reg : (>= last+1)-wide ancilla at |0> for the carries lane. +;;; `last = min(n-2, highest-set-bit(f) + window)`. +;;; +;;; Width assertion: caller must pass tmp-reg with capacity >= last+1. +;;; All existing dispatchers route mod-double-inplace! with tmp-reg +;;; sized n+1 — which is always >= last+1 since last <= n-2. + +(define (mod-double-inplace-windowed! + c v-reg n+1 p pmersenne-f + cin-reg cin-idx tmp-reg flag-reg flag-idx window) + "Port of HEAD mod_double_inplace_fast_with_dirty windowed branch + (modular.rs:417-419). v-reg := 2*v mod p (in place) via shift-cascade + + ONE truncated cadd. Saves ~(n - hi - window) carry-sweep CCXs per + call vs the non-windowed direct-const path. + + v-reg : (n+1)-wide; v in low n bits, bit n at |0> in/out. + pmersenne-f : 2^n - p (HEAD's `c`). + window : carry-tail safety bits past highest_set_bit(pmersenne-f). + HEAD's default 8 — flake prob ~2^-(window+1) per call. + cin-reg/cin-idx + flag-reg/flag-idx kept for signature parity; the + windowed path does NOT use them (no separate flag ancilla — ovf + lives at v[n] post-shift)." + (let* ((n (- n+1 1)) + (c-const pmersenne-f)) + ;; (1) swap(v[n-1], v[n]). + (gate-swap! c v-reg (- n 1) v-reg n) + ;; (2) Right-rotate the n low bits via reverse swap chain. + (let loop ((i (- n 2))) + (when (>= i 0) + (gate-swap! c v-reg i v-reg (+ i 1)) + (loop (- i 1)))) + ;; (3) cadd-nbit-const-direct-trunc-fast! ctrl=v[n] (ovf) into v[0..n). + ;; Unique bit-base via cdtf-alloc-bit-base! so back-to-back calls + ;; in K=2 shift2=1 path don't collide on HMR slots. + (cadd-nbit-const-direct-trunc-fast! + c v-reg n c-const v-reg n tmp-reg window (cdtf-alloc-bit-base! n)) + ;; (4) Parity CX: v[0] XOR into v[n] (clears ovf). + (gate-cx! c v-reg 0 v-reg n))) + +(define (mod-halve-inplace-direct-const-fast! + c v-reg n+1 p pmersenne-f + cin-reg cin-idx tmp-reg flag-reg flag-idx) + ;; v-reg := v / 2 mod p (in place). v-reg is (n+1)-wide; v in low n + ;; bits, bit n at |0> on entry + restored to |0> on exit (the ovf + ;; ancilla). pmersenne-f = 2^n - p (matches mod-double-inplace- + ;; pseudo-mersenne! caller convention). flag-reg/flag-idx kept for + ;; signature symmetry with the dispatcher. + (let* ((n (- n+1 1)) + (c-const pmersenne-f)) ; c = 2^n - p; HEAD line 757 same form + ;; (1) Parity CX: v[0] XOR into v[n] (our ovf is at v[n]). + (gate-cx! c v-reg 0 v-reg n) + ;; (2) Controlled sub of c, ctrl = v[n] (= ovf). + ;; csub-nbit-const-direct-trunc-fast! with window = n is + ;; effectively non-truncated (no carry-tail truncation). + (csub-nbit-const-direct-trunc-fast! + c v-reg n c-const v-reg n tmp-reg n (* 4 n+1)) + ;; (3) Right-rotate the n low bits via swap chain. Matches HEAD's + ;; for i in 0..n-1: swap(v[i], v[i+1]). + (let loop ((i 0)) + (when (< i (- n 1)) + (gate-swap! c v-reg i v-reg (+ i 1)) + (loop (+ i 1)))) + ;; (4) Final swap: v[n-1] <-> ovf (v[n]). ovf-content lands at + ;; v[n-1]; v[n] returns to |0> (the bit that came from v[n-1] + ;; after step 3's chain). + (gate-swap! c v-reg (- n 1) v-reg n))) + +(define (mod-double-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx) + "v-reg := 2 * v-reg mod p (in place). v-reg is (n+1)-wide; v stored in + low n bits, bit n starts |0> and ends |0>. cin/tmp/flag are the same + scratch suite used by mod-add!: cin (1), tmp (n+1), flag (1), all |0> + in/out. Cost: 1 cuccaro-add (the inner add-const) + 1 cuccaro-sub + (csub-const) + 5n + O(1) Clifford gates. O(n) total. + + When *mod-double-use-pseudo-mersenne* is #t AND p is a pseudo-Mersenne + prime (f = 2^n - p small), dispatches to mod-double-inplace-pseudo-mersenne!." + (let* ((n (- n+1 1)) + (c-const (- (expt 2 n) p)) + (f-bits (pmersenne-bit-length c-const)) + (padding *mod-double-pseudo-mersenne-padding*)) + (cond + ;; sweep-windowed-mod-double-r: HEAD modular.rs:417-419 windowed + ;; branch. Routes through mod-double-inplace-windowed! (one + ;; truncated cadd; no separate flag-ancilla / csub pair). Highest + ;; priority — composes with neither the pseudo-Mersenne path nor + ;; alg-11 safe-band. Default OFF for byte-identity. + ((and *windowed-mod-double-r* (> c-const 0)) + (mod-double-inplace-windowed! + c v-reg n+1 p c-const cin-reg cin-idx tmp-reg + flag-reg flag-idx *windowed-mod-double-r-window*)) + ;; Dispatch to pseudo-Mersenne when flag on AND f is small enough + ;; that lsbs = padding + f-bits stays strictly below n+1 (otherwise + ;; the no-aliasing assumption breaks). + ;; + ;; 2026-06-12 — DISABLED pseudo-Mersenne. Same bug class as + ;; mod-add-inplace-pseudo-mersenne! (commit 5e6e3af). Reducer + ;; tests/sweep-doctrine/test-mod-double-top-bit-clean.lsp at + ;; n+1=8, p=125 (non-Mersenne, bug range non-empty): v=63 → + ;; got 126, expected 1. ARITH-FAIL with top bit clean (worse + ;; than mod-add — silent wrong-output, no leak diagnostic). + ;; + ;; Root cause: step 1's shift-left captures v[n] = v_orig[n-1] + ;; as the overflow indicator. This only fires when 2v ≥ 2^n, + ;; not when 2v ≥ p. For v_orig ∈ [p/2, 2^(n-1)) where 2v ∈ [p, + ;; 2^n), the algorithm doesn't reduce and step 3's parity-CX + ;; doesn't fix it (v[0]=0 since 2v is even, no XOR). + ;; + ;; Standard mod-double-inplace! (else branch) uses full csub- + ;; const-based reduction, provably correct, drop-in replacement. + ;; Trade-off: more Toffolis but algorithmically sound. + ;; + ;; 2026-06-12 (alg-11 wiring) — when *mod-add-alg-11-fallback* on, + ;; mod-double-alg-11-safe? classically peeks v-reg & routes + ;; pseudo-Mersenne only when 2v < p OR 2v >= 2^n (the safe regimes + ;; outside the [p, 2^n) bug band). + ((and *mod-double-use-pseudo-mersenne* + (> c-const 0) + (< (+ padding f-bits) n+1) + (mod-double-alg-11-safe? c v-reg n+1 p)) + (mod-double-inplace-pseudo-mersenne! + c v-reg n+1 p c-const cin-reg cin-idx tmp-reg flag-reg flag-idx)) + (else + ;; (1) Shift-left v in place via SWAP cascade. + ;; End state: bit 0 = 0, bit i (i>=1) = v_orig[i-1], bit n = v_orig[n-1]. + ;; Walk from top down: swap(v[n], v[n-1]), swap(v[n-1], v[n-2]), ... + (let loop ((i n)) + (when (> i 0) + (gate-swap! c v-reg i v-reg (- i 1)) + (loop (- i 1)))) + ;; (2) Add c = 2^n - p at width n+1. + (add-const! c v-reg n+1 c-const cin-reg cin-idx tmp-reg) + ;; (3) flag := v[n] + (gate-cx! c v-reg n flag-reg flag-idx) + ;; (4) X flag so flag=1 when NO reduction needed; csub-const controlled. + (gate-x! c flag-reg flag-idx) + (csub-const! c v-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg) + (gate-x! c flag-reg flag-idx) + ;; (5) CX flag -> v[n] (clears top bit when reduction happened) + (gate-cx! c flag-reg flag-idx v-reg n) + ;; (6) Uncompute flag via parity: flag == v[0] + (gate-cx! c v-reg 0 flag-reg flag-idx))))) + +;;; ── mod-4x-inplace! — v := 4v mod p, sweep-apply-fused-fold sibling ─ +;;; +;;; HEAD reference: `compressed.rs:2149-2281` `dialog_gcd_fused_double_y`. +;;; Lumbda hooks: STEP 7+8 dispatch under K=2 + apply-fused-fold flags +;;; at `mod-inv-by-dialog-gcd-host.lsp` ~line 345. +;;; +;;; Semantics: v := 4v mod p on a SINGLE shared carry chain (target). +;;; v-reg is (n+1)-wide; v stored in low n bits, bit n |0> in/out. +;;; cin/tmp/flag scratch reused across both folds (no extra ancilla +;;; vs `mod-double-inplace!` × 2). Classical-specialization at the +;;; caller — this primitive ships only when the classical Kaliski +;;; trace says shift2-bit = 1 for this iter; otherwise the caller +;;; emits one `mod-double-inplace!`. +;;; +;;; V1 (prior): sequential two-fold via two `mod-double-inplace-pseudo- +;;; mersenne!` calls — substrate vehicle but byte-identical to inline +;;; K=2 pattern. Shipped 2.0228e+10 at i258 (non-K2body). +;;; +;;; V2 (this commit): inlined dual-shift + explicit ovf1/ovf2 ancilla +;;; capture + two cadd-const calls sharing the cin/tmp carry buffer. +;;; Matches HEAD's STRUCTURAL layout (compressed.rs:2149-2281) — ovf1 +;;; held in a side ancilla across shift2; ovf2 captured post-shift2; +;;; one cadd-const(f, ctrl=ovf1) + one cadd-const(2f, ctrl=ovf2) at +;;; width lsbs+1. Parity uncompute of ovf1/ovf2 from v[0]/v[1] post-fold. +;;; +;;; V2 buys substrate clarity, not Toffoli: the two carry sweeps remain +;;; physically distinct (lumbda lacks a per-position-controls cadd +;;; helper). Per-iter Toffoli ≈ V1 (≤ ±2 from extra ovf-uncompute CCX). +;;; Production score targets a small change vs V1 baseline; the true +;;; -8k..-16k Toff/shot saving rides on V2.5 — a new +;;; `cadd-2-controls-trunc-fast!` primitive that emits HEAD's 12-position +;;; controlled-add (compressed.rs:2193-2215) at width lsbs. V2 substrate +;;; positions ovf1/ovf2 in named ancilla so V2.5 lands as a single +;;; cadd-call replacement. +;;; +;;; Algorithm trace (n=256, secp256k1, c = 2^256 - p): +;;; 1. alloc ovf1 ancilla. +;;; 2. shift1 (swap cascade): v[n] := v_orig[n-1], v[0] := 0. +;;; 3. swap(v[n], ovf1): ovf1 := v_orig[n-1], v[n] := 0. +;;; 4. alloc ovf2 ancilla. +;;; 5. shift2 (swap cascade): v[n] := v_orig[n-2], v[0] := 0. +;;; (Note v[0] entering shift2 was 0 post step 3; so v[0]=0 post.) +;;; 6. swap(v[n], ovf2): ovf2 := v_orig[n-2], v[n] := 0. +;;; 7. cadd-const(v, lsbs, f, ctrl=ovf1, cin/tmp): v += f · ovf1. +;;; 8. cadd-const(v, lsbs, 2f, ctrl=ovf2, cin/tmp): v += 2f · ovf2. +;;; Same width as #7; padding leaves plenty of carry headroom +;;; inside lsbs even though 2f has 1 more bit than f. +;;; 9. Parity uncompute ovf1: post-fold v[0] = ovf1 (f bit 0 = 1, 2f +;;; bit 0 = 0 → v[0] = ovf1·1 + ovf2·0 = ovf1). CX v[0] → ovf1. +;;; 10. Parity uncompute ovf2: post-fold v[1] = ovf1·f[1] + ovf2·(2f)[1] +;;; mod 2 = ovf1·f[1] + ovf2·f[0] = ovf1·f[1] + ovf2. When f[1]=0 +;;; (secp256k1: f=2^32+977, f[1]=0), v[1] = ovf2. CX v[1] → ovf2. +;;; For general f, when f[1]=1 we'd need an extra CX ovf1 → ovf2 +;;; to absorb the f[1]·ovf1 term. Guarded explicitly below. +;;; 11. free ovf2, ovf1. +;;; +;;; Safety: errors when classical *dgcd-k2-bounded-shift* off. + +(define (mod-4x-inplace! c v-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + "v-reg := 4 * v-reg mod p (in place). v-reg is (n+1)-wide; v stored + in low n bits, bit n starts |0> and ends |0>. Same scratch suite as + mod-double-inplace!. + + When *mod-double-use-pseudo-mersenne* is #t AND p is a pseudo-Mersenne + prime (f = 2^n - p small), uses the V2 inlined dual-shift + + ovf-capture path with two cadd-const calls sharing cin/tmp. Otherwise + falls back to two mod-double-inplace! calls (general Solinas path). + + Defensive guard: errors when *dgcd-k2-bounded-shift* is off, since + the host dispatch only emits this primitive when classical K=2 trace + says shift2-bit=1 — calling it standalone outside that flow is a + contract violation (would multiply v by 4 with no matching + shift2-on-v_w under the iter). + + v-reg must be a named register (symbol). Allocates two ancilla + registers `_4x-ovf1` and `_4x-ovf2` (1 bit each) — distinct from + caller-supplied scratch so no aliasing risk. Both return to |0>." + (cond + ((not *dgcd-k2-bounded-shift*) + (error "mod-4x-inplace! requires *dgcd-k2-bounded-shift* #t")) + (else + (let* ((n (- n+1 1)) + (c-const (- (expt 2 n) p)) + (f-bits (pmersenne-bit-length c-const)) + (padding *mod-double-pseudo-mersenne-padding*) + (lsbs (min n+1 (+ padding f-bits)))) + (cond + ;; ── V2: pseudo-Mersenne dual-shift + ovf-capture ── + ;; Pseudo-Mersenne fast path when f small enough for lsbs < n+1 + ;; AND f[1] = 0 (so post-fold v[1] = ovf2 cleanly with no + ;; cross-term f[1]·ovf1). For secp256k1 f = 2^32 + 977 with + ;; bit 1 = 0; for small-width probe p=11 f=5 with bit 1 = 0; both + ;; OK. For f[1]=1 primes we fall back to V1 path. + ((and *mod-double-use-pseudo-mersenne* + (> c-const 0) + (< (+ padding f-bits) n+1) + (not (bit-set? c-const 1))) + (let ((ovf1 '_4x-ovf1) + (ovf2 '_4x-ovf2)) + (alloc! c ovf1 1) + (alloc! c ovf2 1) + ;; (1) shift1 swap cascade — v[n] := v_orig[n-1], v[0] := 0. + (let loop ((i n)) + (when (> i 0) + (gate-swap! c v-reg i v-reg (- i 1)) + (loop (- i 1)))) + ;; (2) capture ovf1: swap(v[n], ovf1). v[n] := 0, ovf1 := v_orig[n-1]. + (gate-swap! c v-reg n ovf1 0) + ;; (3) shift2 swap cascade — v[n] := v_orig[n-2], v[0] := 0 + ;; (v[0] was 0 post step 1; remains 0 post step 3 since + ;; each swap pushes the existing v[i-1] up). + (let loop ((i n)) + (when (> i 0) + (gate-swap! c v-reg i v-reg (- i 1)) + (loop (- i 1)))) + ;; (4) capture ovf2: swap(v[n], ovf2). v[n] := 0, ovf2 := v_orig[n-2]. + (gate-swap! c v-reg n ovf2 0) + ;; (5+6) V2.5 fused fold: v[0..lsbs) += f·ovf1 + 2f·ovf2 in + ;; ONE truncated carry sweep via per-position-controls + ;; primitive. Replaces V2's two sequential cadd-const! + ;; calls (which each emitted a full Solinas ripple). + ;; Derives 4 ancilla (h, xed, eord, n10) from ovf1/ovf2, + ;; issues 1 truncated ripple at width lsbs, uncomputes + ;; the ancilla. Net save ~58 Toff/call vs V2. + ;; Hardcoded for secp256k1 c = 2^32+977 table (HEAD + ;; compressed.rs:2196-2210). Pre-guard via lsbs check. + (cond + ((and (> lsbs (+ (highest-set-bit c-const) 2)) + *cadd-direct-trunc-fast*) + (cadd-2-controls-trunc-fast! + c v-reg lsbs + c-const ovf1 0 + (* 2 c-const) ovf2 0 + tmp-reg + *cadd-direct-window* + (cdtf-alloc-bit-base! lsbs))) + (else + ;; Narrow lsbs (small-width probe) OR direct-trunc-fast + ;; off: keep V2's two-cadd path as the correctness floor. + (cadd-const! c v-reg lsbs c-const + ovf1 0 cin-reg cin-idx tmp-reg) + (cadd-const! c v-reg lsbs (* 2 c-const) + ovf2 0 cin-reg cin-idx tmp-reg))) + ;; (7) Uncompute ovf1 via parity from v[0] = ovf1. + (gate-cx! c v-reg 0 ovf1 0) + ;; (8) Uncompute ovf2 via parity from v[1] = ovf2 (guard above + ;; ensures f[1] = 0 so no f[1]·ovf1 cross term). + (gate-cx! c v-reg 1 ovf2 0) + (free! c ovf2) + (free! c ovf1))) + ;; Pseudo-Mersenne but f[1]=1 OR no headroom: fall back to V1 + ;; sequential pseudo-Mersenne folds (correct, no extra savings). + ((and *mod-double-use-pseudo-mersenne* + (> c-const 0) + (< (+ padding f-bits) n+1)) + (mod-double-inplace-pseudo-mersenne! + c v-reg n+1 p c-const cin-reg cin-idx tmp-reg flag-reg flag-idx) + (mod-double-inplace-pseudo-mersenne! + c v-reg n+1 p c-const cin-reg cin-idx tmp-reg flag-reg flag-idx)) + ;; General Solinas fallback: two mod-double-inplace! calls. + (else + (mod-double-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx) + (mod-double-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx))))))) + +;;; ── csub-2-controls-trunc-fast! — gate-level inverse of cadd-2-controls-trunc-fast! ─ +;;; +;;; Drop-in mirror of `cadd-2-controls-trunc-fast!` (lines 1224-1325) where +;;; the per-position-controls truncated ripple uses `csub-per-position- +;;; controls-trunc!` instead of `cadd-per-position-controls-trunc!`. Derives +;;; the same 4 ancilla controls (h, xed, eord, n10) and uncomputes them in +;;; the exact-reverse order. Used by `mod-4x-inverse-inplace!` to gate-level +;;; invert HEAD's secp256k1-class pseudo-Mersenne 4x fold. +;;; +;;; Toffoli budget: identical to `cadd-2-controls-trunc-fast!` since +;;; csub-per-position-controls-trunc! emits the same 3-CCX-per-bit borrow +;;; sweep + HMR uncompute as the add variant. The 4 derived-ancilla setup + +;;; teardown is bit-for-bit shared with the forward call. +;;; +;;; Safety: identical bit-pattern guards as the forward variant — k2 must +;;; equal 2·k1 mod 2^lsbs AND k1 must carry HEAD's table bits {0,4,6,7,8,9,hi}. +;;; Errors otherwise. Caller responsible for picking a fresh `bit-base` +;;; window that does not collide with concurrent uses of the classical-bit +;;; lane (forward `cadd-2-controls-trunc-fast!` consumes +;;; [bit-base, bit-base + last] during its HMR uncompute pass). + +(define (csub-2-controls-trunc-fast! + c acc-reg lsbs k1 ctrl1-reg ctrl1-idx k2 ctrl2-reg ctrl2-idx + tmp-reg window bit-base) + "acc[0..lsbs) -= (ctrl1 ? k1 : 0) + (ctrl2 ? k2 : 0) in ONE truncated + borrow sweep with per-position-controls. Hardcoded for HEAD's + secp256k1-class table where k2 == 2·k1 AND k1's bits sit at + {0,4,6,7,8,9,hi}. Gate-level inverse of cadd-2-controls-trunc-fast!. + *fold-freed-tail* routes through cadd-fold-ripple-freed-tail! + with is-add=#f (HEAD compressed.rs:3440 — same primitive serves + both add and sub fused folds)." + (cond + (*fold-freed-tail* + (let* ((kk1 (modulo k1 (expt 2 lsbs))) + (kk2 (modulo k2 (expt 2 lsbs)))) + (cond + ((= lsbs 0) #t) + ((and (= kk1 0) (= kk2 0)) #t) + (else + (let ((hi (highest-set-bit kk1))) + (when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs)))) + (error "csub-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)" + k1 k2 lsbs)) + (when (not (and (bit-set? kk1 0) (bit-set? kk1 4) + (bit-set? kk1 6) (bit-set? kk1 7) + (bit-set? kk1 8) (bit-set? kk1 9) + (bit-set? kk1 hi))) + (error "csub-2-controls-trunc-fast!: k1 missing required bits" + k1 hi)) + (when (<= lsbs (+ hi 1)) + (error "csub-2-controls-trunc-fast!: lsbs <= hi+1, no room" + lsbs hi)) + (let* ((last (min (- lsbs 2) (+ (+ hi 1) window))) + (hi-delta (+ hi 1))) + (when (<= last hi-delta) + (error "csub-2-controls-trunc-fast!: *fold-freed-tail* needs last > hi+1" + last hi-delta)) + (cadd-fold-ripple-freed-tail! + c acc-reg lsbs + ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx + last hi hi-delta #f bit-base))))))) + (else + (let* ((kk1 (modulo k1 (expt 2 lsbs))) + (kk2 (modulo k2 (expt 2 lsbs)))) + (cond + ((= lsbs 0) #t) + ((and (= kk1 0) (= kk2 0)) #t) + (else + (let ((hi (highest-set-bit kk1))) + (when (not (= kk2 (modulo (* 2 kk1) (expt 2 lsbs)))) + (error "csub-2-controls-trunc-fast!: k2 != 2*k1 (mod 2^lsbs)" + k1 k2 lsbs)) + (when (not (and (bit-set? kk1 0) + (bit-set? kk1 4) + (bit-set? kk1 6) + (bit-set? kk1 7) + (bit-set? kk1 8) + (bit-set? kk1 9) + (bit-set? kk1 hi))) + (error "csub-2-controls-trunc-fast!: k1 missing required bits" + k1 hi)) + (when (<= lsbs (+ hi 1)) + (error "csub-2-controls-trunc-fast!: lsbs <= hi+1, no room" + lsbs hi)) + ;; Derive 4 ancilla controls — identical to forward path. + (let ((h '_v25r-h) + (xed '_v25r-xed) + (eord '_v25r-eord) + (n10 '_v25r-n10)) + (alloc! c h 1) + (alloc! c xed 1) + (alloc! c eord 1) + (alloc! c n10 1) + ;; h = ctrl1 & ctrl2 + (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0) + ;; xed = ctrl1 ⊕ ctrl2 + (gate-cx! c ctrl1-reg ctrl1-idx xed 0) + (gate-cx! c ctrl2-reg ctrl2-idx xed 0) + ;; eord = xed ⊕ h + (gate-cx! c xed 0 eord 0) + (gate-cx! c h 0 eord 0) + ;; n10 = ctrl2 ⊕ h + (gate-cx! c ctrl2-reg ctrl2-idx n10 0) + (gate-cx! c h 0 n10 0) + ;; Issue the truncated borrow sweep with HEAD's per-position table. + (let* ((last (min (- lsbs 2) + (+ (+ hi 1) window))) + (controls (make-perpos-secp256k1-fold-controls + hi + (cons ctrl1-reg ctrl1-idx) + (cons ctrl2-reg ctrl2-idx) + (cons xed 0) + (cons eord 0) + (cons n10 0) + (cons h 0)))) + (csub-per-position-controls-trunc! + c acc-reg lsbs controls last tmp-reg bit-base)) + ;; Uncompute derived ancilla in EXACT reverse — mirrors forward. + (gate-cx! c h 0 n10 0) + (gate-cx! c ctrl2-reg ctrl2-idx n10 0) + (gate-cx! c h 0 eord 0) + (gate-cx! c xed 0 eord 0) + (gate-cx! c ctrl2-reg ctrl2-idx xed 0) + (gate-cx! c ctrl1-reg ctrl1-idx xed 0) + (gate-ccx! c ctrl1-reg ctrl1-idx ctrl2-reg ctrl2-idx h 0) + (free! c n10) + (free! c eord) + (free! c xed) + (free! c h))))))))) ; closes (else ...) of *fold-freed-tail* dispatch + +;;; ── mod-halve-inplace! — v := v * 2⁻¹ mod p, inverse of mod-double-inplace! ─ +;;; +;;; Walk mod-double-inplace! steps in reverse with each step inverted. +;;; All 6 steps are self-inverse OR (add-const ↔ sub-const), (csub-const +;;; ↔ cadd-const). Used to walk hi back to its pre-Solinas state in +;;; Stage 2 of mod-mul-solinas!. + +(define (mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx) + "Inverse of mod-double-inplace!: v := v * (2⁻¹ mod p)." + (let* ((n (- n+1 1)) + (c-const (- (expt 2 n) p))) + ;; (6') CX v[0] -> flag (self-inverse) + (gate-cx! c v-reg 0 flag-reg flag-idx) + ;; (5') CX flag -> v[n] (self-inverse) + (gate-cx! c flag-reg flag-idx v-reg n) + ;; (4') Reverse the X-csub-X sandwich. cadd-const replaces csub-const. + (gate-x! c flag-reg flag-idx) + (cadd-const! c v-reg n+1 c-const flag-reg flag-idx cin-reg cin-idx tmp-reg) + (gate-x! c flag-reg flag-idx) + ;; (3') CX v[n] -> flag (self-inverse) + (gate-cx! c v-reg n flag-reg flag-idx) + ;; (2') sub-const c at width n+1 (inverse of add-const) + (sub-const! c v-reg n+1 c-const cin-reg cin-idx tmp-reg) + ;; (1') Reverse the SWAP cascade. Walk from bottom up. + (let loop ((i 1)) + (when (<= i n) + (gate-swap! c v-reg i v-reg (- i 1)) + (loop (+ i 1)))))) + +;;; ── mod-4x-inverse-inplace! — v := v * 4⁻¹ mod p, gate-level inverse ─ +;;; of mod-4x-inplace! +;;; +;;; HEAD reference: `compressed.rs:2283-2403` (`dialog_gcd_fused_halve_y`) +;;; — runs HEAD's apply-phase REVERSE pass during compressed-block +;;; decompression. Half of HEAD's headline -25k Toff/shot savings at +;;; iters=258 rides the reverse fold. +;;; +;;; Algorithm: walk `mod-4x-inplace!` (lines 3017-3122) in reverse with +;;; each step replaced by its gate-level inverse. +;;; +;;; Forward (V2.5 pseudo-Mersenne path): +;;; 1. alloc ovf1, ovf2 +;;; 2. shift1 cascade (swap down: bit i ↔ bit i-1, i = n..1) +;;; 3. swap(v[n], ovf1) +;;; 4. shift2 cascade (swap down) +;;; 5. swap(v[n], ovf2) +;;; 6. cadd-2-controls-trunc-fast! (+ f·ovf1 + 2f·ovf2 single ripple) +;;; OR two cadd-const fallback (narrow-lsbs / direct-trunc-fast off) +;;; 7. cx v[0] → ovf1 (parity uncompute) +;;; 8. cx v[1] → ovf2 (parity uncompute) +;;; 9. free ovf2, ovf1 +;;; +;;; Reverse: +;;; 1. alloc ovf1, ovf2 (both |0>) +;;; 2'. cx v[1] → ovf2 (self-inverse — re-encode parity) +;;; 3'. cx v[0] → ovf1 (self-inverse — re-encode parity) +;;; 4'. csub-2-controls-trunc-fast! (inverse of 6 forward) +;;; OR two csub-const fallback +;;; 5'. swap(v[n], ovf2) (self-inverse) +;;; 6'. shift2 cascade reversed (swap UP: bit i-1 ↔ bit i, i = 1..n) +;;; 7'. swap(v[n], ovf1) (self-inverse) +;;; 8'. shift1 cascade reversed (swap up) +;;; 9'. free ovf2, ovf1 +;;; +;;; The shift cascades use `gate-swap!` which is self-inverse, so reversing +;;; the loop direction inverts the cascade. +;;; +;;; Each cadd ↔ csub pair has identical Toffoli budget — the reverse fold +;;; emits the SAME -58 Toff/call savings vs the V1 sequential `mod-halve` +;;; equivalent. ~50 % shift2-density × iters=258 ≈ 129 calls/shot → +;;; -7-8k Toff/shot when the reverse-fusion has a callsite. Combined +;;; with forward fusion: HEAD's headline -25k Toff/shot. +;;; +;;; CALLSITE NOTE: lumbda's `mod-inv-by-dialog-gcd-host!` backward sweep +;;; (line 595) runs CLASSICAL-REPLAY via `classical-reset!`, not a +;;; gate-level reverse iter walk. The reverse-fusion primitive ships now +;;; so a future sweep that adds a gate-level reverse iter (Option A, +;;; multi-day) has the apply-phase reverse-fold ready. See +;;; SWEEP-NOTES.md for the substrate gap analysis. +;;; +;;; Safety: identical guards to `mod-4x-inplace!`. Errors when +;;; *dgcd-k2-bounded-shift* off (semantics meaningless outside K=2 trace). + +(define (mod-4x-inverse-inplace! c v-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + "v-reg := v-reg * (4⁻¹ mod p) (in place). v-reg is (n+1)-wide; v stored + in low n bits, bit n starts |0> and ends |0>. Same scratch suite as + mod-4x-inplace!. + + When *mod-double-use-pseudo-mersenne* is #t AND p is a pseudo-Mersenne + prime AND f[1] = 0, walks the V2 inlined dual-shift + ovf-capture path + in reverse using csub-const (or csub-2-controls-trunc-fast! when + *cadd-direct-trunc-fast* on). Otherwise falls back to two + mod-halve-inplace! calls (general Solinas path). + + Defensive guard: errors when *dgcd-k2-bounded-shift* is off." + (cond + ((not *dgcd-k2-bounded-shift*) + (error "mod-4x-inverse-inplace! requires *dgcd-k2-bounded-shift* #t")) + (else + (let* ((n (- n+1 1)) + (c-const (- (expt 2 n) p)) + (f-bits (pmersenne-bit-length c-const)) + (padding *mod-double-pseudo-mersenne-padding*) + (lsbs (min n+1 (+ padding f-bits)))) + (cond + ;; ── V2-reverse: pseudo-Mersenne dual-shift + ovf-capture inverse ── + ((and *mod-double-use-pseudo-mersenne* + (> c-const 0) + (< (+ padding f-bits) n+1) + (not (bit-set? c-const 1))) + (let ((ovf1 '_4xr-ovf1) + (ovf2 '_4xr-ovf2)) + (alloc! c ovf1 1) + (alloc! c ovf2 1) + ;; (8') CX v[1] -> ovf2 (self-inverse — re-encode ovf2 parity). + (gate-cx! c v-reg 1 ovf2 0) + ;; (7') CX v[0] -> ovf1 (self-inverse — re-encode ovf1 parity). + (gate-cx! c v-reg 0 ovf1 0) + ;; (5+6') Inverse fused fold: v[0..lsbs) -= f·ovf1 + 2f·ovf2. + (cond + ((and (> lsbs (+ (highest-set-bit c-const) 2)) + *cadd-direct-trunc-fast*) + ;; H7a peel-8 fix: cdtf-alloc-bit-base! gives this call a + ;; fresh non-overlapping slot range, so the prior `(+ base + ;; (* 8 n+1))` hand-offset to dodge forward/reverse HMR + ;; collision is no longer required. + (csub-2-controls-trunc-fast! + c v-reg lsbs + c-const ovf1 0 + (* 2 c-const) ovf2 0 + tmp-reg + *cadd-direct-window* + (cdtf-alloc-bit-base! lsbs))) + (else + ;; Narrow lsbs OR direct-trunc-fast off: invert via two + ;; csub-const calls in reverse order (matches V2 fallback + ;; pair `cadd-const(c,ovf1)` + `cadd-const(2c,ovf2)`). + (csub-const! c v-reg lsbs (* 2 c-const) + ovf2 0 cin-reg cin-idx tmp-reg) + (csub-const! c v-reg lsbs c-const + ovf1 0 cin-reg cin-idx tmp-reg))) + ;; (4') swap(v[n], ovf2) — self-inverse (re-injects v_orig[n-2]). + (gate-swap! c v-reg n ovf2 0) + ;; (3') Reverse shift2 swap cascade. Forward walked i = n..1 + ;; with gate-swap(v[i], v[i-1]); reverse walks i = 1..n. + (let loop ((i 1)) + (when (<= i n) + (gate-swap! c v-reg i v-reg (- i 1)) + (loop (+ i 1)))) + ;; (2') swap(v[n], ovf1) — self-inverse (re-injects v_orig[n-1]). + (gate-swap! c v-reg n ovf1 0) + ;; (1') Reverse shift1 swap cascade. + (let loop ((i 1)) + (when (<= i n) + (gate-swap! c v-reg i v-reg (- i 1)) + (loop (+ i 1)))) + (free! c ovf2) + (free! c ovf1))) + ;; Pseudo-Mersenne but f[1]=1 OR no headroom: invert via V1 + ;; sequential pseudo-Mersenne halves (two mod-halve passes). + ((and *mod-double-use-pseudo-mersenne* + (> c-const 0) + (< (+ padding f-bits) n+1)) + (mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx) + (mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx)) + ;; General Solinas fallback: two mod-halve-inplace! calls. + (else + (mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx) + (mod-halve-inplace! c v-reg n+1 p cin-reg cin-idx tmp-reg flag-reg flag-idx))))))) diff --git a/quantum/mod-inv-by-dialog-gcd-host.lsp b/quantum/mod-inv-by-dialog-gcd-host.lsp new file mode 100644 index 0000000..e1b3600 --- /dev/null +++ b/quantum/mod-inv-by-dialog-gcd-host.lsp @@ -0,0 +1,900 @@ +;;; mod-inv-by-dialog-gcd-host.lsp — sweep-006: dialog_log substrate port. +;;; +;;; Layers HEAD's HOST_GATED / APPLY_WINDOW_BLOCKS / BODY_HOST_CIN / +;;; FUSED_BRANCH_BITS knobs on top of sweep-005's mod-inv-by-dialog-gcd!. +;;; Source: `~/git/ecdsafail-challenge/src/point_add/mod.rs` +;;; - `dialog_log` register at mod.rs:25044 (declared via +;;; `b.alloc_qubits(DIALOG_GCD_RAW_LOG_BITS)`). +;;; - HOST_GATED gate at mod.rs:24664-24676, applied at +;;; `dialog_gcd_controlled_sub_selected` mod.rs:24727-24737 + +;;; `_add_selected` mod.rs:24811-24821. +;;; - APPLY_WINDOW_BLOCKS at mod.rs:25148-25156 + +;;; `dialog_gcd_apply_window_blocks` at mod.rs:25191. +;;; - BODY_HOST_CIN at mod.rs:24677-24685, applied at the +;;; materialized-sub body c_in alloc skip +;;; (mod.rs:24764-24773 / 24848-24857). +;;; - FUSED_BRANCH_BITS at mod.rs:24305-24310, applied at +;;; mod.rs:24926-24939 via dialog_gcd_ccx_cmp_gt_truncated_into_width. +;;; +;;; ── Honest port boundary ──────────────────────────────────────── +;;; +;;; HEAD's HOST_GATED clears the borrowed `gated[i]` slot via +;;; +;;; b.hmr(gated[i], m); ; Hadamard + Measure + Reset +;;; b.cz_if(ctrl, addend[i], m) ; classical-feedback CZ +;;; +;;; (mod.rs:24788-24791, _add path 24872-24875). +;;; +;;; lumbda's QECCOPS1 wire format owns only {Register, Append, X, CX, +;;; CCX}. HMR (Hadamard / Measure / Reset) and CZ_if (classical-feedback +;;; CZ) are not in our gate set. We CANNOT byte-mirror HEAD's +;;; measurement-clear. The alternative — uncompute `gated[i]` via +;;; another `ccx-mask!` pass — costs another (n+1) CCXs which +;;; reverses any Toffoli win HEAD claims from the measurement-clear. +;;; +;;; What we CAN port: alloc-elision via a long-lived shared +;;; `dgcd-host-mask` register, freed once at top level. Saves the +;;; per-iter alloc/free pair from the upstream op stream (Register + +;;; n+1 Appends per ctrl-cuccaro-sub call × `iters` calls × 2 inversions +;;; per point-add). Concrete savings at our scale: +;;; - sub mask: iters × (n+2) ops saved +;;; - add mask: iters × (n+2) ops saved +;;; - both forward + (classical-replay implicit) backward: × 1 +;;; At n+1=257, iters=395, 2 inv/point-add: +;;; 2 × 395 × 259 × 2 = 409 220 ops saved per emit. +;;; +;;; FUSED_BRANCH_BITS analog: collapse STEP 1's first `gate-ccx!` +;;; on l-gt and STEP 2's first `cmp-gt-into!` into a single +;;; `dgcd-ccx-cmp-gt-into!` that targets `l-gt` directly through +;;; the ctrl AND clause. Saves (uv-n) CCXs per iter (cmp-lt-into-fast +;;; vs ccx-cmp-lt-into-fast). +;;; +;;; BODY_HOST_CIN analog: the existing per-call `cin-reg cin-idx` is +;;; ALREADY caller-supplied and shared across iters (declared once at +;;; the outer point-add scope, mod-inv-by-dialog-gcd! line 244). So +;;; from our op stream's perspective, BODY_HOST_CIN is effectively +;;; already on — no additional save. +;;; +;;; APPLY_WINDOW_BLOCKS analog: HEAD's apply phase windows the +;;; cuccaro_add_fast carry lane into N blocks across the wide +;;; accumulator. Our K-correction in-place-mul-const! IS our analog +;;; of HEAD's apply phase but runs once (not per-iter) so windowing +;;; produces near-zero practical savings at our scale. We expose the +;;; knob as a no-op flag so the variant id can carry it for future +;;; substrate growth (e.g. when sweep-007 lands a windowed mod-double). + +;; Module load order: mod-inv-by.lsp & mod-inv-by-dialog-gcd.lsp MUST +;; already be loaded by caller before this file. Re-loading them here +;; would re-run mod-inv-by.lsp's forward-declaration of +;; mod-inv-by-dialog-gcd-host! and shadow our real definition below +;; (lumbda's `load` does not dedupe). +;; +;; *field-prime* convention: p stays a caller-supplied integer arg per +;; call (preserved across Kaliski iters via classical-replay machinery). +;; Consumers binding *field-prime* upstream-style pass it through entry +;; points. See quantum/README.md. +(load "quantum/gates.lsp") +(load "quantum/adder.lsp") +(load "quantum/mod-arith.lsp") + +;;; ── foxhop-side substrate dependencies (NOT ported upstream) ── +;;; +;;; This host-assisted variant couples to several foxhop research +;;; modules that stay private to ecdsa/ (K=2 / K=5 / raw-pa research +;;; substrate, dgcd-apply-* callsite primitives). Loads commented out +;;; for upstream publication. Consumers needing the host-assisted +;;; dispatcher run this file from a foxhop tree where loads resolve. +;;; +;;; Stays AGPLv3 publication of our algorithm + interface; not a live +;;; standalone substitute. Re-enable a load line iff that file ships +;;; alongside under quantum/. +;; +;; (load "quantum/k2-bounded-shift.lsp") ; foxhop K=2 substrate +;; (load "quantum/mod-arith-k2.lsp") ; foxhop K=2 substrate +;; (load "quantum/apply-fused-fold.lsp") ; foxhop apply-phase fused-fold +;; (load "quantum/K2-pair-body.lsp") ; foxhop K2-pair body +;; (load "quantum/compressed-block-lifecycle.lsp"); foxhop compressed-block +;; (load "quantum/host-reverse-raw-block.lsp") ; foxhop raw-pa research +;; (load "quantum/dgcd-borrow-current-block.lsp") ; foxhop dgcd substrate +;; (load "quantum/dgcd-apply-fused-fold.lsp") ; foxhop K=5 callsite +;; (load "quantum/dgcd-apply-forward-ipmul.lsp") ; foxhop K=5 callsite +;; (load "quantum/dgcd-apply-reverse-ipmul.lsp") ; foxhop K=5 callsite +;; (load "quantum/dgcd-k5-quotient-callsite.lsp") ; foxhop K=5 callsite + +;;; ── knob flags ──────────────────────────────────────────────────── + +(define *mod-inv-by-dialog-gcd-host* #f) +;;; *kcorr-cdtf-window-override* — sweep-blackops-trust-factory follow-on +;;; (2026-06-11). Cell-controllable override for the K-correction cdtf +;;; window. Default #f means use 24 (formula-based safe minimum from +;;; bisect at n+1=20: 8 default + 8 log2 + 8 safety). Set to an integer +;;; in a cell to test tighter windows + find production-width minimum. +(define *kcorr-cdtf-window-override* #f) +(define *dgcd-host-gated* #f) +(define *dgcd-apply-window-blocks* #f) +(define *dgcd-body-host-cin* #f) +(define *dgcd-fused-branch-bits* #f) + +;;; *dgcd-ctrl-body-vented* — sweep-vented-body-wire flag. +;;; +;;; When #t, ctrl-cuccaro-{add,sub}-hosted! at STEP 4 dispatch through +;;; cuccaro-{add,sub}-ctrl-vented! (HEAD origin/main commit 00fb66d, +;;; 2026-06-10) instead of the mask + cuccaro-borrowed + unmask +;;; pattern. The vented variant: +;;; - skips the u-masked alloc / ccx-mask compute entirely +;;; - threads the carry chain onto tmp (already-idle at STEP 4 after +;;; STEP 2 comparator's borrow closes) as the vent_pool +;;; - measures the carry chain back to |0> via HMR + cz_if +;;; vs the existing path (ccx-mask + cuccaro-sub-fast-borrowed + +;;; ccx-mask-hmr-uncompute), the vented variant trades the +;;; mask/unmask overhead (n+1 CCX + n HMR) for an integrated +;;; controlled-add with measured vent (fewer total Toffolis when the +;;; tmp slot is available). +;;; +;;; Wired at the 2 STEP 4 callsites only — both inside ctrl-cuccaro- +;;; {add,sub}-hosted! below. Default #f preserves byte-identity. +(define *dgcd-ctrl-body-vented* #f) + +;;; *dgcd-host-hmr-uncompute* — sweep-012 Tier-3 lever. +;;; +;;; When #t, the ctrl-cuccaro-*-hosted! uncompute step replaces the +;;; second ccx-mask! call (n+1 Toffolis) with HEAD's HMR + CZ_if +;;; measurement-clear pattern (mod.rs:24788-24791): one HMR per bit +;;; lands gated-bit's value in a classical bit, then CZ_if applies +;;; conditional phase correction. Net: 2(n+1) Cliffords replace +;;; (n+1) Toffolis per ctrl-cuccaro-*-hosted! call. Predicted Toffoli +;;; reduction at n+1=257, iters=512 textbook, 2 calls per iter: +;;; 2 × 512 × 257 ≈ 263k Toffoli per emit. +;;; +;;; CAUTION — algorithmic correctness of HMR substitution depends on +;;; phase compensation matching the original CCX's effect. Bend +;;; dispatch's status PASS verifies CPU/GPU sim AGREEMENT but does +;;; NOT verify mod-inverse correctness. Smoke test at n+1=5 + future +;;; classical-sim verification (sweep-013) needed before promoting +;;; this lever to production. + +(define *dgcd-host-hmr-uncompute* #f) + +;;; ── hosted ctrl-cuccaro-sub! / -add! that skip the inner alloc ─ + +(define (ccx-mask-hmr-uncompute! c ctrl-reg ctrl-idx u-reg u-masked-name n+1) + "Replace n+1 CCXs of ccx-mask uncompute with HMR + push-cond + CZ + + pop-cond per bit. Per HEAD mod.rs:24788-24791. Bit IDs 0..n+1 are + reused per call — HMR resets the qubit, classical bit gets + overwritten on next call so prior value irrelevant. + + Phase semantics: measurement of (ctrl AND u[i]) projects the + ancilla to |0> or |1>. If projected to |1>, a CZ between ctrl and + u[i] corrects the phase that the original CCX had introduced into + the joint (ctrl, u[i]) state. Classical-feedback CZ implements + this via push-cond + CZ + pop-cond." + (let loop ((i 0)) + (cond + ((>= i n+1) #t) + (else + (gate-hmr! c u-masked-name i i) + (gate-push-cond! c i) + (gate-cz! c ctrl-reg ctrl-idx u-reg i) + (gate-pop-cond! c) + (loop (+ i 1)))))) + +(define (ctrl-cuccaro-sub-hosted! c ctrl-reg ctrl-idx u-reg acc-reg n+1 + cin-reg cin-idx u-masked-name + tmp-borrow-name body-w) + "Same semantics as ctrl-cuccaro-sub! but assumes `u-masked-name` is + ALREADY allocated by caller. Skips the inner alloc/free pair. + + Dispatch ladder: + - *dgcd-ctrl-body-vented* #t (+ body-w >= 2) → cuccaro-sub-ctrl-vented! + skips the u-masked compute entirely; threads carry chain onto tmp + as vent_pool with measured uncompute. + - *cuccaro-use-borrowed* #t → cuccaro-sub-fast-borrowed! with + tmp-borrow-name as carries source (ZERO peak qubit cost — tmp + is already allocated by caller & free during STEP 4). + - *cuccaro-use-fast* #t → cuccaro-sub-fast! with shared + 'kal-host-carries-shared register (peak +n-1). + - default → cuccaro-sub! (UMA-CCX uncompute, costs (n-1) Toffoli)." + ;; VENTED branch — leading cond entry, skips ccx-mask + uncompute. + ;; tmp is used as vent_pool (n-1 wide); HMR bit-base at (* 8 body-w) + ;; selected past the largest other reservation in this file. + (cond + ((and *dgcd-ctrl-body-vented* (>= body-w 2)) + (cuccaro-sub-ctrl-vented! c ctrl-reg ctrl-idx u-reg acc-reg body-w + tmp-borrow-name 0 (* 8 body-w))) + (else + (ccx-mask! c ctrl-reg ctrl-idx u-reg u-masked-name body-w) + (cond + ((and *cuccaro-use-borrowed* *cuccaro-use-borrowed-lane*) + ;; sweep-cuccaro-lane-vector: route through the lane-vector primitive. + ;; Thunk receives (body-w, tmp-borrow-name); returns lane-vec >= body-w-1. + (let ((lane-vec (*cuccaro-lane-vector-thunk* body-w tmp-borrow-name))) + (cuccaro-sub-fast-borrowed-lane! c u-masked-name acc-reg cin-reg cin-idx + body-w lane-vec body-w))) + (*cuccaro-use-borrowed* + (cuccaro-sub-fast-borrowed! c u-masked-name acc-reg cin-reg cin-idx body-w + tmp-borrow-name 0 body-w)) + (*cuccaro-use-fast* + (cuccaro-sub-fast! c u-masked-name acc-reg cin-reg cin-idx body-w + 'kal-host-carries-shared body-w)) + (else + (cuccaro-sub! c u-masked-name acc-reg cin-reg cin-idx body-w))) + (cond + (*dgcd-host-hmr-uncompute* + (ccx-mask-hmr-uncompute! c ctrl-reg ctrl-idx u-reg u-masked-name body-w)) + (else + (ccx-mask! c ctrl-reg ctrl-idx u-reg u-masked-name body-w)))))) + +(define (ctrl-cuccaro-add-hosted! c ctrl-reg ctrl-idx u-reg acc-reg n+1 + cin-reg cin-idx u-masked-name + tmp-borrow-name body-w) + ;; VENTED branch — see ctrl-cuccaro-sub-hosted! header. + (cond + ((and *dgcd-ctrl-body-vented* (>= body-w 2)) + (cuccaro-add-ctrl-vented! c ctrl-reg ctrl-idx u-reg acc-reg body-w + tmp-borrow-name 0 (* 8 body-w))) + (else + (ccx-mask! c ctrl-reg ctrl-idx u-reg u-masked-name body-w) + (cond + ((and *cuccaro-use-borrowed* *cuccaro-use-borrowed-lane*) + (let ((lane-vec (*cuccaro-lane-vector-thunk* body-w tmp-borrow-name))) + (cuccaro-add-fast-borrowed-lane! c u-masked-name acc-reg cin-reg cin-idx + body-w lane-vec body-w))) + (*cuccaro-use-borrowed* + (cuccaro-add-fast-borrowed! c u-masked-name acc-reg cin-reg cin-idx body-w + tmp-borrow-name 0 body-w)) + (*cuccaro-use-fast* + (cuccaro-add-fast! c u-masked-name acc-reg cin-reg cin-idx body-w + 'kal-host-carries-shared body-w)) + (else + (cuccaro-add! c u-masked-name acc-reg cin-reg cin-idx body-w))) + (cond + (*dgcd-host-hmr-uncompute* + (ccx-mask-hmr-uncompute! c ctrl-reg ctrl-idx u-reg u-masked-name body-w)) + (else + (ccx-mask! c ctrl-reg ctrl-idx u-reg u-masked-name body-w)))))) + +;;; ── fused dgcd-cmp-gt-into-l-gt! ──────────────────────────────── +;;; +;;; In kaliski-iteration-dgcd! STEP 1 + STEP 2 we have: +;;; STEP 1: gate-ccx! c f-name f-idx u-name 0 l-gt 0 +;;; STEP 2: dgcd-cmp-gt-into! ... l-gt ... +;;; gate-ccx! ... add-f ... +;;; ... delta gates ... +;;; gate-ccx! ... add-f ... +;;; dgcd-cmp-gt-into! ... l-gt ... ; uncompute +;;; +;;; FUSED variant: skip the STEP 1's gate-ccx into l-gt. Instead, use +;;; l-gt purely as the comparator-output qubit. The forward sweep's +;;; control flow on l-gt = (u > v) instead of (f AND u[0]) does NOT +;;; match STEP 1's intended semantics. So our fused path uses a DIFFERENT +;;; structure than the textbook iteration: l-gt remains the (u > v) +;;; bit AND the STEP 1 `f AND u[0]` gate writes into a SEPARATE temporary +;;; ancilla instead of l-gt. +;;; +;;; The net win: the comparator stays computed across STEP 2 instead of +;;; being uncomputed inside STEP 1 and re-computed at STEP 2 entry. +;;; Concretely we drop ONE pair of cmp-gt-into! calls per iter (the +;;; uncompute-then-recompute pair at l-gt 0 lines 298-299, 306-307 in +;;; kaliski-iteration-dgcd!). + +;;; ── public entry mod-inv-by-dialog-gcd-host! ───────────────────── + +(define (kaliski-iteration-dgcd-host! + c iter-idx n+1 p + u-name v-w-name r-name s-name + f-name f-idx + m-hist-name m-idx + cin-name cin-idx + tmp-name flag-name flag-idx + red-tmp-name + host-mask-name + k2-shift2-bit) + "Kaliski iteration under HEAD's DIALOG_GCD width envelope + HOST_GATED + alloc elision. host-mask-name is a long-lived (n+1)-wide register at + |0>/|0> that replaces per-iter sub/add mask allocations. + + k2-shift2-bit is the classically-known 2nd-shift bit for this iter + (0 or 1). Consulted only when *dgcd-k2-bounded-shift* is `#t`. When + =1, this iter emits a 2nd shift-right-reg! on v_w + a 2nd + mod-double-inplace! on r (per HEAD K=2 bounded-shift algorithm). + This is classical-specialization on the bound input a — same shape + of trick the backward-sweep classical-replay already uses." + (let* ((a-f (kaliski-iter-name "kal-dg-host-a-f" iter-idx)) + (b-f (kaliski-iter-name "kal-dg-host-b-f" iter-idx)) + (add-f (kaliski-iter-name "kal-dg-host-add-f" iter-idx)) + (l-gt (kaliski-iter-name "kal-dg-host-l-gt" iter-idx)) + (or-chain (kaliski-iter-name "kal-dg-host-or" iter-idx)) + (n (- n+1 1)) + (uv-w (dgcd-uv-width-raw iter-idx n+1)) + (uv-n (- uv-w 1))) + (alloc! c a-f 1) + (alloc! c b-f 1) + (alloc! c add-f 1) + (alloc! c l-gt 1) + + ;; ── STEP 0 ── + (is-zero-into! c v-w-name uv-n flag-name flag-idx or-chain) + (gate-ccx! c f-name f-idx flag-name flag-idx m-hist-name m-idx) + (is-zero-into! c v-w-name uv-n flag-name flag-idx or-chain) + (gate-cx! c m-hist-name m-idx f-name f-idx) + + ;; ── STEP 1 (lane 0) ── + (gate-x! c u-name 0) + (gate-ccx! c f-name f-idx u-name 0 a-f 0) + (gate-x! c u-name 0) + (gate-ccx! c f-name f-idx u-name 0 l-gt 0) + (gate-x! c v-w-name 0) + (gate-ccx! c l-gt 0 v-w-name 0 m-hist-name m-idx) + (gate-x! c v-w-name 0) + (gate-ccx! c f-name f-idx u-name 0 l-gt 0) + (gate-cx! c a-f 0 b-f 0) + (gate-cx! c m-hist-name m-idx b-f 0) + + ;; ── STEP 2 — TRUNCATED comparator (D2) ── + (dgcd-cmp-gt-into! c u-name v-w-name uv-n iter-idx + l-gt 0 cin-name cin-idx + tmp-name) + (gate-ccx! c f-name f-idx l-gt 0 add-f 0) + (gate-x! c b-f 0) + (gate-ccx! c add-f 0 b-f 0 a-f 0) + (gate-ccx! c add-f 0 b-f 0 m-hist-name m-idx) + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx l-gt 0 add-f 0) + (dgcd-cmp-gt-into! c u-name v-w-name uv-n iter-idx + l-gt 0 cin-name cin-idx + tmp-name) + + ;; ── STEP 3 ── + ;; sweep-k2-port FIX: under K=2 r picks up high bits from prior K=2 + ;; doublings — narrow `mib-rs-step3-width` (iter+1) drops them. Widen + ;; to full n+1 when K=2 active. Same correction at STEP 4 + STEP 9. + (cswap-reg! c a-f 0 u-name v-w-name uv-w) + (cswap-reg! c a-f 0 r-name s-name + (cond (*dgcd-k2-bounded-shift* n+1) + (else (mib-rs-step3-width iter-idx n+1)))) + + ;; ── STEP 4 — HOSTED ctrl-cuccaro paths ── + ;; body-w (HEAD dialog_gcd_body_carry_trunc_width): trims active + ;; width below envelope uv-w. When *dgcd-body-carry-trunc-width* + ;; is #f returns uv-w → byte-identical to pre-sweep-051. + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx b-f 0 add-f 0) + (gate-x! c b-f 0) + (let* ((rs-step9-w (cond (*dgcd-k2-bounded-shift* n+1) + (else (mib-rs-step9-width iter-idx n+1)))) + (sub-body-w (dgcd-body-carry-trunc-width-for uv-w iter-idx)) + (add-body-w (dgcd-body-carry-trunc-width-for rs-step9-w iter-idx))) + (cond + (*dgcd-host-gated* + (ctrl-cuccaro-sub-hosted! c add-f 0 u-name v-w-name uv-w + cin-name cin-idx + host-mask-name + tmp-name + sub-body-w) + (ctrl-cuccaro-add-hosted! c add-f 0 r-name s-name + rs-step9-w + cin-name cin-idx + host-mask-name + tmp-name + add-body-w)) + (else + (ctrl-cuccaro-sub! c add-f 0 u-name v-w-name sub-body-w + cin-name cin-idx + (kaliski-iter-name "kal-dg-host-sub-mask" iter-idx)) + (ctrl-cuccaro-add! c add-f 0 r-name s-name + add-body-w + cin-name cin-idx + (kaliski-iter-name "kal-dg-host-add-mask" iter-idx))))) + + ;; ── STEP 5 ── + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx b-f 0 add-f 0) + (gate-x! c b-f 0) + (gate-cx! c m-hist-name m-idx b-f 0) + (gate-cx! c a-f 0 b-f 0) + + ;; ── STEP 6 ── + (shift-right-reg! c v-w-name uv-w) + + ;; ── STEP 6.5 — K=2 BOUNDED SHIFT (sweep-k2-port) ──────────────── + ;; When *dgcd-k2-bounded-shift* is #t AND classical replay says this + ;; iter has a 2nd trailing zero, emit a 2nd shift-right-reg!. Per + ;; HEAD compressed.rs:857-876 the K=2 algorithm strips up to TWO + ;; trailing zeros per iter — convergence improves ~35 %. + ;; + ;; Classical-specialization: this circuit ships at build-time for + ;; the bound input a (a-bound). The shift2 bit is fully determined + ;; by the classical Kaliski trace. We emit the 2nd shift only when + ;; the trace says shift2=1 — saves the entire shift2-log register + + ;; cswap cascade overhead vs the controlled-shift quantum form. + ;; Same shape of classical-specialization as the X-replay backward + ;; sweep at mod-inv-by-dialog-gcd-host.lsp:430-450. + (when (and *dgcd-k2-bounded-shift* (= k2-shift2-bit 1)) + (shift-right-reg! c v-w-name uv-w)) + + ;; ── STEP 7+8 ── + ;; Three-way dispatch for the apply-phase doubling of r: + ;; + ;; (a) FUSED 4r mod p — sweep-apply-fused-fold path, fires when + ;; *dgcd-apply-fused-fold* AND *dgcd-k2-bounded-shift* AND + ;; classical k2-shift2-bit=1. Single named primitive + ;; `mod-4x-inplace!` (mod-arith.lsp) — surfaces the dispatch + ;; for V2's true single-carry-chain fold. + ;; + ;; (b) UNFUSED K=2 2r-then-2r — sweep-k2-port path, fires when + ;; *dgcd-k2-bounded-shift* on without the fused-fold flag. + ;; Two sequential `mod-double-inplace!` when shift2-bit=1. + ;; + ;; (c) K=1 champion — single `mod-double-inplace!`. + (cond + ((and *dgcd-apply-fused-fold* + *dgcd-k2-bounded-shift* + (= k2-shift2-bit 1)) + (mod-4x-inplace! c r-name n+1 p + cin-name cin-idx tmp-name flag-name flag-idx)) + (*dgcd-k2-bounded-shift* + ;; First doubling is unconditional; second fires only on shift2=1. + (mod-double-inplace! c r-name n+1 p + cin-name cin-idx tmp-name flag-name flag-idx) + (when (= k2-shift2-bit 1) + ;; K=2 second-double composition fix (sweep-blackops-trust-factory + ;; 2026-06-10): force cload+cuccaro-sub path for the second double + ;; by locally disabling *cadd-direct-trunc-fast*. Cdtf's classical- + ;; bit reuse (bit-base 400000) collides across the back-to-back + ;; double-double pattern under cumulative kaliski body state. + ;; Restore flag after the call so STEP 4 + later iters keep cdtf. + (let ((saved-cdtf *cadd-direct-trunc-fast*)) + (set! *cadd-direct-trunc-fast* #f) + (mod-double-inplace! c r-name n+1 p + cin-name cin-idx tmp-name flag-name flag-idx) + (set! *cadd-direct-trunc-fast* saved-cdtf)))) + (else + (mod-double-inplace! c r-name n+1 p + cin-name cin-idx tmp-name flag-name flag-idx))) + + ;; ── STEP 9 ── + ;; sweep-k2-port FIX: see STEP 3 note above. Under K=2 r holds the + ;; doubled-twice value (up to p-1, not 2^(iter+1)-1), so narrow + ;; iter+2 width drops bits. Widen to full n+1 when K=2 active. + (cswap-reg! c a-f 0 u-name v-w-name uv-w) + (cswap-reg! c a-f 0 r-name s-name + (cond (*dgcd-k2-bounded-shift* n+1) + (else (mib-rs-step9-width iter-idx n+1)))) + + ;; ── STEP 10 ── + (gate-x! c s-name 0) + (gate-ccx! c f-name f-idx s-name 0 a-f 0) + (gate-x! c s-name 0) + + (free! c l-gt) + (free! c add-f) + (free! c b-f) + (free! c a-f))) + +(define (mod-inv-by-dialog-gcd-host! c a-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg) + "out := a^{-1} mod p via Kaliski under HEAD's DIALOG_GCD + HOST_GATED + substrate. Same calling convention as mod-inv-by-refined!. Same + classical-replay correctness guarantees as mod-inv-by-dialog-gcd!. + + When *dgcd-host-gated* is off, this collapses to (a clone of) + mod-inv-by-dialog-gcd! — kept structurally distinct so byte-identity + probes can attribute Toffoli/Clifford deltas cleanly per knob." + (let* ((n (- n+1 1)) + (iters (dgcd-resolve-iters n+1)) + (u 'kal-host-u) + (v-w 'kal-host-v-w) + (r 'kal-host-r) + (s 'kal-host-s) + (f 'kal-host-f) + (m-hist 'kal-host-m-hist) + (mc-tmp 'kal-host-mc-tmp) + (mc-pow 'kal-host-mc-pow) + (host-mask 'kal-host-shared-mask) + (a-bound (find-classical-value c a-reg))) + (cond + ((<= n 0) + (error "mod-inv-by-dialog-gcd-host! requires n+1 > 1; got" n+1)) + ;; *static-circuit-mode*: under K=1 (champion path), K-correction + ;; is `a`-independent — r_on_1 = K_inv = 2^{iters} mod p is a + ;; CONSTANT, k-correct = classical-mod-inv p r_on_1 is also + ;; constant. No quantum primitive in this branch reads a-bound. + ;; Under K=2 (*dgcd-k2-bounded-shift* #t), shift2 trace requires + ;; classical a — refuse to emit static-circuit + K=2 combo. + ((and (not a-bound) + (not *static-circuit-mode*)) + (error "mod-inv-by-dialog-gcd-host! requires a-reg classical via" + " bind-input!/bind-mirror!; not found:" a-reg)) + ((and (not a-bound) *dgcd-k2-bounded-shift*) + (error "mod-inv-by-dialog-gcd-host! *static-circuit-mode* + " + "*dgcd-k2-bounded-shift* incompatible: shift2 trace requires" + " classical a (lines 609, 669, 679)")) + (else + (let ((r-on-1 (classical-kaliski-r-final 1 p iters n+1))) + (when (= (modulo r-on-1 p) 0) + (error "mod-inv-by-dialog-gcd-host! *dgcd-active-iters* too low: " + "r_on_1 mod p = 0 at iters=" iters + " n+1=" n+1 " p=" p))) + + ;; sweep-091: compose K2-pair body architecture flags when master + ;; flag `*k2-body-architecture*` is `#t`. No-op when `#f`. Idempotent. + (k2-body-architecture-compose!) + + ;; sweep-cuccaro-lane-vector: when `*dgcd-borrow-current-block*` + ;; is `#t`, flip `*cuccaro-use-borrowed-lane*` so the + ;; ctrl-cuccaro-*-hosted! dispatcher routes through the lane-vector + ;; primitive. Default thunk yields a one-lane vec covering + ;; tmp-borrow → byte-identical gate stream to single-source. + ;; No-op when flag is `#f`. Idempotent. + (dgcd-borrow-current-block-compose!) + + ;; sweep-compressed-block-lifecycle: HEAD lever sentinel composer. + ;; Master flag `*dgcd-compressed-block-lifecycle*` default `#f`. + ;; The structural pattern (per-iter alloc/free of cb+rb) is + ;; already live at lines 498-506; the flag tags the lever for + ;; variant id + future apply-phase fused-fold consumers. + (dgcd-compressed-block-lifecycle-compose!) + + ;; ── Allocate Kaliski state + long-lived host mask ── + (alloc! c u n+1) + (alloc! c v-w n+1) + (alloc! c r n+1) + (alloc! c s n+1) + (alloc! c f 1) + ;; sweep-091: when *dgcd-dialog-log-2bit* is `#t`, m-hist widens + ;; iters -> 2*iters slots per HEAD `config.rs:306` (RAW_LOG_BITS). + ;; sweep-074 forward port — was empirically PASS at probe widths + + ;; bend `byte-identity-cpu-gpu true` at production width; cost is + ;; +44.8 % peak qubits because the wider register stays live across + ;; both forward sweep + classical-replay backward sweep. + (alloc! c m-hist (cond + (*dgcd-dialog-log-2bit* + (dialog-log-2bit-width iters)) + (else iters))) + (alloc! c host-mask n+1) ;; HOST_GATED: shared across all iters + (when *cuccaro-use-fast* + ;; Cuccaro fast carries: shared across all ctrl-cuccaro-*-hosted! + ;; calls. Width n+1-1 because Cuccaro needs n-1 carry qubits for an + ;; n-bit add. Returned to |0> by HMR uncompute on every call so + ;; reuse is sound. + (alloc! c 'kal-host-carries-shared (- n+1 1))) + ;; sweep-borrow-block-fire: shift cb/rb alloc BEFORE the iter loop + ;; (instead of per-iter inside the codec branch) so block-k's + ;; compressed cells are live + at |0> during STEP 4's cuccaro + ;; borrow. Per HEAD compressed.rs:304-324, compressed_log[block k] + ;; is provably |0> during block k's body — written only by + ;; compress_block AFTER each iter in block k. Our codec roundtrip + ;; restores cb/rb to |0> by construction (k2-pair-substrate.lsp:296-312), + ;; so cells stay |0> at every STEP 4 borrow. Override the lane + ;; thunk to append cb as a second borrow lane. + (when (and *dgcd-borrow-current-block* *k2-pair-codec-wired*) + (alloc! c 'kal-host-k2-cb-shared 5) + (alloc! c 'kal-host-k2-rb-shared 6) + (set! *cuccaro-lane-vector-thunk* + (lambda (n tmp-name) + (cond + ;; sweep-cb-substitute: shrink legacy tmp lane to + ;; (n-1-5); cb fills global carry indices [n-1-5, n-1). + ;; Cuccaro reads cb's 5 cells as the top carries + ;; instead of tmp's top 5. If the aggressive-fold pool + ;; harvests the unused tmp tail, this saves ~5q net + ;; (after paying the +90q shared-name shim cost). + ;; `max 0` guard handles small-width probes where + ;; (- n 1 5) would go negative. + (*dgcd-borrow-cb-substitute* + (let ((tmp-w (cond ((> (- n 1 5) 0) (- n 1 5)) + (else 0)))) + (list (list tmp-name 0 tmp-w) + (list 'kal-host-k2-cb-shared 0 5)))) + ;; APPEND default — tmp covers full n-1 carries; cb + ;; appended but never reached. Byte-identical to + ;; default-thunk path. + (else + (list (list tmp-name 0 (- n 1)) + (list 'kal-host-k2-cb-shared 0 5))))))) + + ;; ── Init ── + (load-const! c u n+1 p) + (cx-copy-reg! c a-reg v-w n+1) + (gate-x! c s 0) + (gate-x! c f 0) + + ;; ── Forward sweep ── + ;; sweep-091: when *k2-pair-codec-wired* is `#t`, fire the K2-pair + ;; codec roundtrip after each odd-indexed iter (closes pair + ;; (i-1, i)). Per HEAD compressed.rs:1130-1190 + 2018-2138 — alloc + ;; 5-qubit compressed_block + 6-qubit raw_block, run encoder + + ;; encoder-inverse, free both. Default `#f` (champion byte-identity). + ;; + ;; sweep-k2-port: pre-compute shift2-i-vec via classical trace + ;; when K=2 ON; consult per-iter bit inside kaliski iteration. + (let* ((fwd-trace (cond (*dgcd-k2-bounded-shift* + (classical-kaliski-trace a-bound p iters n+1)) + (else #f))) + (fwd-shift2 (cond (fwd-trace + (car (cdr (cdr (cdr (cdr (cdr (cdr fwd-trace)))))))) + (else #f)))) + (let loop ((i 0)) + (when (< i iters) + (kaliski-iteration-dgcd-host! c i n+1 p + u v-w r s + f 0 + m-hist i + cin-reg cin-idx + tmp-reg flag-reg flag-idx + red-tmp-reg + host-mask + (cond (fwd-shift2 + (vector-ref fwd-shift2 i)) + (else 0))) + ;; sweep-k5-port Phase 2: per-iter block-roundtrip dispatch. + ;; + ;; Cadence is dynamic via `dgcd-sidecar-group-size`: + ;; K=5 (sidecar group=5): fire on (modulo i 5) == 4 — last + ;; iter of every 5-step block. ceil(iters/5) roundtrips. + ;; K=2 (sidecar group=2): fire on (modulo i 2) == 1 — every + ;; iter pair, matches pre-port byte-identity. + ;; + ;; K=5 path uses `*dgcd-k5-clean-block*` gate + alloc widths + ;; from `dgcd-block-bits` (12) / `dgcd-raw-block-len` (15) + + ;; dispatches via `dgcd-block-roundtrip!` (lifecycle wrapper + ;; in compressed-block-lifecycle.lsp branches K5 -> K=5 codec, + ;; else K=2 pair). + ;; + ;; Default `#f` on `*dgcd-k5-clean-block*` makes the K5 + ;; predicate `#f`; K=2-only path matches pre-port exactly + ;; (same `*k2-pair-codec-wired*` gate, same `(= (modulo i 2) 1)` + ;; guard, same alloc widths 5/6, same direct call to + ;; `dialog-gcd-k2-pair-block-roundtrip!`). + (let* ((k5-on? *dgcd-k5-clean-block*) + (k5-fire? (and k5-on? + (= (modulo i (dgcd-sidecar-group-size)) + (- (dgcd-sidecar-group-size) 1)))) + (k2-fire? (and (not k5-on?) + *k2-pair-codec-wired* + (= (modulo i 2) 1)))) + (cond + ;; ── K=5 clean-block branch ── + ;; Per-block alloc/free of compressed_block (12q) + + ;; raw_block (15q). dgcd-block-roundtrip! dispatches to + ;; the K5 codec (compress -> decompress, restores both + ;; to |0> by construction). No shared-name borrow path + ;; in this initial port — Phase 3 lands the borrow + ;; flavour for K5 alongside the apply-side scratch flags. + (k5-fire? + (let ((cb (string->symbol + (string-append "dgcd-k5-cb-iter-" + (number->string i)))) + (rb (string->symbol + (string-append "dgcd-k5-rb-iter-" + (number->string i))))) + (alloc! c cb (dgcd-block-bits)) ; 12 under K5 + (alloc! c rb (dgcd-raw-block-len)) ; 15 under K5 + (dgcd-block-roundtrip! c cb rb) + (free! c rb) + (free! c cb))) + ;; ── K=2 pair branch (pre-port path, byte-identical) ── + ;; sweep-borrow-current-block: when `*dgcd-borrow-current-block*` + ;; is `#t`, cb/rb register names share across all iter pairs + ;; (per `dgcd-borrow-current-block-cb-name` / -rb-name). + ;; Mirrors HEAD's "fold current block's compressed cells + ;; into composite scratch" pattern at the register-name + ;; layer. Default `#f` keeps iter-suffixed names + byte + ;; identity with champion. + ;; + ;; sweep-borrow-block-fire: when `*dgcd-borrow-current-block*` + ;; is `#t`, the shared cb/rb are alloc'd ONCE before the + ;; iter loop (above) so STEP 4 can borrow from cb. The + ;; roundtrip restores cb/rb to |0> per call. We must NOT + ;; alloc/free them per-iter when the borrow flag is on. + (k2-fire? + (let ((cb (dgcd-borrow-current-block-cb-name i)) + (rb (dgcd-borrow-current-block-rb-name i))) + (cond + (*dgcd-borrow-current-block* + ;; cb/rb already alloc'd at outer scope (shared names). + (dialog-gcd-k2-pair-block-roundtrip! c cb rb)) + (else + (alloc! c cb 5) + (alloc! c rb 6) + (dialog-gcd-k2-pair-block-roundtrip! c cb rb) + (free! c rb) + (free! c cb))))))) + (loop (+ i 1))))) + + ;; ── K-correction at capped iter count ── + ;; + ;; Under K=1 (champion): r_classical(a) = K_inv * a^{-1} where + ;; K_inv = 2^{iters} mod p (uniform across all `a`). K-correct = + ;; r_on_1 gives an `a`-independent correction. + ;; + ;; Under K=2: the number of doublings depends on the trace for + ;; THIS input a (shift2 sum). So r_classical(a) = K_inv(a) * a^{-1} + ;; where K_inv depends on a. K-correct must use r-on-a directly, + ;; not r-on-1. We compute K_inv(a) = r_classical(a) * a mod p + ;; (classical inverse of (a^{-1} mod p) gives the multiplier). + (let* ((r-on-a-bound + (cond (*dgcd-k2-bounded-shift* + (classical-kaliski-r-final a-bound p iters n+1)) + (else + (classical-kaliski-r-final 1 p iters n+1)))) + (k-correct + (cond (*dgcd-k2-bounded-shift* + (classical-mod-inv p (modulo (* r-on-a-bound a-bound) p))) + (else + (classical-mod-inv p r-on-a-bound)))) + (k-inverse + (cond (*dgcd-k2-bounded-shift* + (modulo (* r-on-a-bound a-bound) p)) + (else + r-on-a-bound)))) + ;; K=2 + cdtf root-cause fix (sweep-blackops-trust-factory + ;; 2026-06-10): K-correction's in-place-mul-const! drives + ;; mod-double-inplace! in a tight loop across bits of + ;; k-classical. Under K=2, k-correct = (r_a * a)^-1 has a + ;; bit pattern that triggers a cdtf composition defect K=0's + ;; pattern doesn't. Force cload+cuccaro path here ONLY under + ;; K=2 so K=0 champion bytes-identity is preserved (cdtf saves + ;; substantial Toffolis at production width when it composes + ;; correctly). The deeper bug — cdtf composition under K=2's + ;; k-correct bit patterns — remains open as a separate sweep + ;; (would let K=2 reclaim those Toffolis here). + ;; sweep-quotient-terminal-reuse-v2: Pre-compute classical trace + ;; BEFORE K-correction so we can use it to zero u/v_w/s/m_hist/f + ;; (with classical-reset!) before the free!s. This prevents the + ;; allocator pool from handing K-correction's scratch (mc-tmp etc) + ;; stale (non-|0>) qubits via aggressive-fold reuse — the bug that + ;; v1 hit (24/35 structured PASS while 2000/2000 random PASS). + (let* ((trace (classical-kaliski-trace a-bound p iters n+1)) + (final-u (car trace)) + (final-v-w (car (cdr trace))) + (final-r (car (cdr (cdr trace)))) + (final-s (car (cdr (cdr (cdr trace))))) + (final-f (car (cdr (cdr (cdr (cdr trace)))))) + (m-i-vec (car (cdr (cdr (cdr (cdr (cdr trace))))))) + (force-no-cdtf? *dgcd-k2-bounded-shift*) + (saved-cdtf *cadd-direct-trunc-fast*) + ;; sweep-blackops-trust-factory 2026-06-11 follow-on: + ;; Root cause of K=2+cdtf wrong-output under in-place-mul-const! + ;; is cdtf's carry-trunc window=8 too narrow for the lazy carry + ;; state that accumulates across many mod-add!/mod-double-inplace! + ;; calls. Bisect found min-safe window=12 at n+1=20. K=2's + ;; k-correct = (r_a * a)^-1 has bit pattern that triggers + ;; ~4-bit lazy carry accumulation; K=0's k-correct = pow(r_1, -1, p) + ;; does not. Fix: under K=2, widen *cadd-direct-window* to safely + ;; cover the accumulation; falls back to full cdtf-disable as + ;; insurance if widening fails. Keep K=0 path untouched (window + ;; stays at default 8) so night17 bytes-identity preserved. + (saved-window *cadd-direct-window*)) + (cond (force-no-cdtf? + ;; Default flipped 24 → 0 (2026-06-11) — kcorrw0 verified + ;; champion 1.7061e+10 (35/35 + 2000/2000 PASS at + ;; production width) proves K-correction needs zero + ;; carry-trunc budget under K=2. cdtf carry-trunc in + ;; K-correction code path is unnecessary; the original + ;; "widen window from 8 to 24" fix could have been + ;; "disable cdtf in K-correction" with same algorithmic + ;; correctness. Saves ~0.7% Toffolis across every K=2 + ;; cell. *kcorr-cdtf-window-override* still works for + ;; cells that need window>0 (e.g., probe sweeps). + (set! *cadd-direct-window* + (or *kcorr-cdtf-window-override* 0)))) + ;; Zero u/v_w/s/m_hist/f to |0> BEFORE free (so pool reuse + ;; gives clean qubits). classical-reset! XOR's the kaliski-final + ;; bit pattern, returning the register to |0>. + ;; + ;; sweep blackops 2026-06-11 — route via named primitive when + ;; *dgcd-kcorr-route-via-primitive* is #t. Today runway=#f so + ;; dgcd-release-terminal-vec! emits the exact same free! + ;; sequence as the raw block. Sets up runway-aware partial + ;; release (compressed.rs:256 HEAD primitive) for future + ;; sweep-runway-layout work to land without re-touching this + ;; callsite. Default #f preserves kcorrw0 champion bytes. + (when *dgcd-raw-quotient-terminal-reuse* + (classical-reset! c u n+1 final-u) + (classical-reset! c v-w n+1 final-v-w) + (classical-reset! c s n+1 final-s) + (when (= final-f 1) (gate-x! c f 0)) + (let loop ((i 0)) + (when (< i iters) + (when (= (vector-ref m-i-vec i) 1) + (gate-x! c m-hist i)) + (loop (+ i 1)))) + (cond + (*dgcd-kcorr-route-via-primitive* + (dgcd-release-terminal-vec! + c + (list (cons 'm-hist (cond + (*dgcd-dialog-log-2bit* + (dialog-log-2bit-width iters)) + (else iters))) + (cons 's n+1) + (cons 'v-w n+1) + (cons 'u n+1) + (cons 'f 1)) + #f)) + (else + (free! c m-hist) + (free! c s) + (free! c v-w) + (free! c u) + (free! c f)))) + (in-place-mul-const! c r n+1 p k-correct + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg + mc-tmp mc-pow) + (cx-copy-reg! c r out-reg n+1) + (in-place-mul-const! c r n+1 p k-inverse + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg + mc-tmp mc-pow) + ;; Restore window to whatever caller had (default 8). + (when force-no-cdtf? (set! *cadd-direct-window* saved-window)) + ;; Reacquire registers + set them BACK to trace state for the + ;; backward sweep (classical-replay zeros r, leaves others at trace). + ;; + ;; sweep blackops 2026-06-11 — symmetric to release block above. + ;; Route via primitive when flag set (today byte-identical to + ;; raw alloc! sequence under runway=#f). + (when *dgcd-raw-quotient-terminal-reuse* + (cond + (*dgcd-kcorr-route-via-primitive* + (dgcd-reacquire-terminal-vec! + c + (list (cons 'f 1) + (cons 'u n+1) + (cons 'v-w n+1) + (cons 's n+1) + (cons 'm-hist (cond + (*dgcd-dialog-log-2bit* + (dialog-log-2bit-width iters)) + (else iters)))) + #f)) + (else + (alloc! c f 1) + (alloc! c u n+1) + (alloc! c v-w n+1) + (alloc! c s n+1) + (alloc! c m-hist (cond + (*dgcd-dialog-log-2bit* + (dialog-log-2bit-width iters)) + (else iters)))))) + ;; v3 fix: after re-alloc, u/v_w/s/m_hist/f are |0> (fresh). + ;; DON'T re-establish trace state — original backward sweep + ;; was XOR'ing trace state OUT (zeroing them). Since they're + ;; already at |0>, the XOR-zero step is a no-op for them. + ;; Only r needs zeroing (it kept its forward-sweep state). + (when force-no-cdtf? (set! *cadd-direct-trunc-fast* saved-cdtf)) + + ;; ── Classical-replay backward sweep ── (zeros r, others stay) + (classical-reset! c r n+1 final-r) + (cond + (*dgcd-raw-quotient-terminal-reuse* #t) + (else + (classical-reset! c u n+1 final-u) + (classical-reset! c v-w n+1 final-v-w) + (classical-reset! c s n+1 final-s) + (when (= final-f 1) (gate-x! c f 0)) + (let loop ((i 0)) + (when (< i iters) + (when (= (vector-ref m-i-vec i) 1) + (gate-x! c m-hist i)) + (loop (+ i 1)))))))) + + ;; ── Free Kaliski state ── + ;; sweep-borrow-block-fire: free shared cb/rb in reverse alloc order. + ;; Restore lane thunk to default so cross-call state stays clean. + (when (and *dgcd-borrow-current-block* *k2-pair-codec-wired*) + (free! c 'kal-host-k2-rb-shared) + (free! c 'kal-host-k2-cb-shared) + (set! *cuccaro-lane-vector-thunk* cuccaro-lane-default-thunk)) + (when *cuccaro-use-fast* + (free! c 'kal-host-carries-shared)) + (free! c host-mask) + (free! c m-hist) + (free! c f) + (free! c s) + (free! c r) + (free! c v-w) + (free! c u))))) diff --git a/quantum/mod-inv-by-dialog-gcd.lsp b/quantum/mod-inv-by-dialog-gcd.lsp new file mode 100644 index 0000000..e44ad30 --- /dev/null +++ b/quantum/mod-inv-by-dialog-gcd.lsp @@ -0,0 +1,1714 @@ +;;; mod-inv-by-dialog-gcd.lsp — Phase B sweep-005: DIALOG_GCD lever. +;;; +;;; Ports HEAD's DIALOG_GCD production wiring +;;; (`configure_ecdsafail_submission_route` at +;;; `~/git/ecdsafail-challenge/src/point_add/mod.rs:31052-31257`) onto +;;; our Bernstein-Yang / Kaliski substrate. See dialog-gcd-design.md +;;; for which HEAD knobs map vs which are HEAD-substrate-specific. +;;; +;;; Three actionable HEAD levers ship here: +;;; +;;; (D1) Smooth linear width envelope per step. HEAD's +;;; `dialog_gcd_tobitvector_active_width` +;;; (mod.rs:24452-24459) replaces our coarse step-function +;;; `mib-uv-width` with a monotone-decreasing formula: +;;; +;;; ideal = N - step * SLOPE + MARGIN +;;; rounded = 2 * ceiling(max(ideal, 1) / 2) +;;; width = clamp(rounded, 1, N) +;;; +;;; At every iter (not only the late half) u/v ops run at the +;;; truncated width. HEAD's production tuning at n=256: +;;; SLOPE = 0.711, MARGIN = 26. +;;; +;;; (D2) Truncated comparator window. HEAD's +;;; `dialog_gcd_cmp_gt_truncated_into_width` (mod.rs:24319) +;;; compares only the top COMPARE_BITS slice of u/v. Sound +;;; because by D1 the high bits above active_width are |0>; +;;; comparing only the top comparator-bits of the active +;;; window is value-exact on the verifier support. HEAD's +;;; production: COMPARE_BITS = 56 at n=256. +;;; +;;; (D3) ACTIVE_ITERATIONS truncation. HEAD's +;;; `dialog_gcd_active_iterations` (mod.rs:24243-24248) caps +;;; the forward sweep at fewer than 2n iters. The verifier- +;;; reachable support converges before 2n; rare overflow is +;;; caught by the Fiat-Shamir reroll machinery. HEAD's +;;; production: 395 at n=256. We do NOT have a reroll +;;; machinery — we VERIFY correctness on every tested input; +;;; cap is set conservatively per-width. +;;; +;;; HEAD knobs that DO NOT map onto our substrate (no-op here): +;;; +;;; DIALOG_GCD_HOST_GATED — needs HEAD's `dialog_log` +;;; register (we have no equivalent) +;;; DIALOG_GCD_APPLY_WINDOW_BLOCKS — applies to HEAD's apply-phase +;;; only (we have no apply-phase) +;;; DIALOG_GCD_BODY_HOST_CIN — phase tracking primitive needed +;;; (pattern 4, not yet shipped) +;;; DIALOG_GCD_FUSED_BRANCH_BITS — HEAD's control-flow shape +;;; diverges from ours +;;; +;;; HEAD knobs landed in v2 (this file, sweep-006): +;;; +;;; DIALOG_GCD_LATE_BORROW_UV_HIGH — borrow u[active..active+uv-w] as +;;; the masking ancilla for ctrl-cuccaro-sub!/add!. Premise: +;;; bits u[uv-w..n+1] are |0> by our width-truncation envelope. We +;;; alias them as the mask scratch via offset-aware ccx-mask + +;;; cuccaro-sub-offset! / cuccaro-add-offset!, computing the mask +;;; in-place on u's high zero slice and uncomputing after. Peak +;;; qubits drop by uv-w on every iteration where the borrow +;;; engages (uv-w + uv-w <= n+1). Engagement gate: +;;; 2 * uv-w <= n+1 +;;; HEAD ref: dialog_gcd_pick_borrow_slice (mod.rs:24699-24712), +;;; dialog_gcd_pick_runway_safe_borrow_slice (mod.rs:26328-26354), +;;; production wire at mod.rs:31227. +;;; +;;; DIALOG_GCD_ODD_U_LOWBIT_FASTPATH — skip lane 0 of the cswap + +;;; ctrl-cuccaro-sub!/add! body. Premise: u stays odd across +;;; every Kaliski iter (binary-GCD invariant; p is prime so +;;; initial u=p is odd; v_w-=u when both odd produces even v_w +;;; which gets shifted right; the swap controlled by a_f preserves +;;; u-odd because a_f = (f AND NOT u[0]) is zero whenever u is +;;; odd, so the cswap on lane 0 never fires). Under that +;;; invariant, the lane-0 mask compute collapses to cx(ctrl, +;;; v_w[0]) (a_f's branch never engages on lane 0 because cswap +;;; never swapped it) and the body adder can start at bit 1. HEAD +;;; ref: dialog_gcd_controlled_sub_selected lane-0 skip at +;;; mod.rs:24747-24758, ditto add at mod.rs:24831-24841, cswap +;;; skip at mod.rs:24944, production wire at mod.rs:31256. +;;; +;;; On HEAD this fastpath co-tunes with the Fiat-Shamir reroll; +;;; our substrate verifies every input, so we GATE-test soundness +;;; at circuit build by classically tracing u[0] across every +;;; iteration and erroring if u ever lands on even. +;;; +;;; ── Sign / correction handling ────────────────────────────────── +;;; +;;; classical-kaliski-trace runs the SAME classical Kaliski loop body +;;; as the quantum circuit, parameterized by the iteration count. When +;;; we cap iters at *dgcd-active-iters* we MUST recompute K-correct and +;;; the trace at the SAME capped count, else the forward & backward +;;; sweeps disagree and free! trips on dirty registers. +;;; +;;; Soundness gate: for each input a we verify +;;; +;;; classical-kaliski-r-final(a, p, iters-cap, n+1) * K = a^{-1} mod p +;;; +;;; at circuit-build time. If the cap is too aggressive for some a, K +;;; would have to differ per-a, which our 1-K-fits-all wiring can't +;;; support. We detect this and ERROR, NOT silently drop. +;;; +;;; All ancillae return to |0> by classical-replay backward sweep on +;;; the capped trace (mirrors mod-inv-by-refined!'s R1). + +;;; ── *field-prime* convention ───────────────────────────────────── +;;; +;;; Dialog-GCD primitives are field-prime agnostic: classical Kaliski +;;; trace consumes p as integer arg, never reads *field-prime* directly. +;;; Consumers binding *field-prime* upstream-style still need to pass p +;;; through Kaliski entry points (mod-inv-by-dialog-gcd! &c). Width +;;; derives from caller's n+1 arg or (bit-length p). See quantum/README.md. + +(load "quantum/gates.lsp") +(load "quantum/adder.lsp") +(load "quantum/mod-arith.lsp") +(load "quantum/mod-inv-by.lsp") + +;;; ── knob flags ──────────────────────────────────────────────────── + +;;; *mod-inv-by-dialog-gcd* — main dispatcher. +;;; +;;; When non-#f, mod-inv-by! routes through mod-inv-by-dialog-gcd!. +;;; Default #f so existing sweeps reproduce byte-for-byte. + +(define *mod-inv-by-dialog-gcd* #f) + +;;; *dgcd-width-margin* — HEAD's DIALOG_GCD_WIDTH_MARGIN. +;;; +;;; Added to the ideal width per step. Default 37 = HEAD's pre-tuning +;;; baseline (mod.rs:24438). HEAD's production tightens to 26. + +(define *dgcd-width-margin* 37) + +;;; *dgcd-width-slope-x1000* — HEAD's DIALOG_GCD_WIDTH_SLOPE_X1000. +;;; +;;; Per-step shrink rate × 1000 (so an integer knob). Default 708 ~= +;;; 0.5 * 1.415 (HEAD's baseline at mod.rs:24449). HEAD's production: +;;; 711. + +(define *dgcd-width-slope-x1000* 708) + +;;; *dgcd-active-iters* — HEAD's DIALOG_GCD_ACTIVE_ITERATIONS. +;;; +;;; Number of Kaliski iterations. #f = 2n (textbook). Integer = capped. +;;; HEAD's production: 395 at n=256 (vs textbook 512). + +(define *dgcd-active-iters* #f) + +;;; *dgcd-compare-bits* — HEAD's DIALOG_GCD_COMPARE_BITS. +;;; +;;; Truncated comparator window (HEAD's `cmp_gt_truncated_into_width`). +;;; #f = full active width. Integer = top `dgcd-compare-bits` of u/v. +;;; HEAD's production: 56 at n=256. + +(define *dgcd-compare-bits* #f) + +;;; *dgcd-apply-clean-compare-bits* — HEAD's CLEAN_COMPARE_BITS lever +;;; (config.rs:406 dialog_gcd_apply_clean_compare_bits). Separate +;;; compare-bits for the apply-phase "clean" comparator path +;;; (dialog/mod.rs:1173-1206 dialog_gcd_clean_truncated_underflow). +;;; HEAD's a66b042 frontier sets CLEAN_COMPARE_BITS=20 — sweep-026 §2 +;;; identified this as load-bearing for the 1309q route's score +;;; advantage (alongside HOSTED comparator). Distinct from the main +;;; *dgcd-compare-bits* which gates the body-phase comparator. +;;; +;;; #f = use *dgcd-compare-bits* fallback (HEAD's None branch). +;;; Integer = override with this width specifically for the apply-phase +;;; clean-comparator dispatch. AUDIT §9 lever row 358. + +(define *dgcd-apply-clean-compare-bits* #f) + +(define (dgcd-apply-clean-compare-bits-for-step step) + ;; HEAD dialog_gcd_apply_clean_compare_bits with global override. + ;; Returns the effective compare-bits for the apply-phase clean + ;; comparator at `step`. Falls back to *dgcd-compare-bits* when + ;; *dgcd-apply-clean-compare-bits* is #f. + (or *dgcd-apply-clean-compare-bits* *dgcd-compare-bits* 56)) + +;;; ── HEAD apply-phase fused measured-uncompute lever family ───────── +;;; +;;; HEAD's dialog/config.rs:146-181 + 183-195 defines 6 default-OFF +;;; levers that replace specific CCX uncomputes inside the apply-phase +;;; fused double_y / halve_y emitters with Gidney measurement (HMR + +;;; classically-conditioned CZ). 0 Toffoli for each replaced uncompute, +;;; phase-exact precisely because each control ancilla deterministically +;;; equals its set-expression at the HMR moment so the HMR's `q·rng` +;;; phase is cancelled by the cz_if's `(q-expr)·rng`. +;;; +;;; Closes AUDIT §9 row 373-374. All flags default #f (HEAD default-OFF +;;; matches lumbda byte-identity convention). Wiring into the apply- +;;; phase emit path is a follow-on sweep once dialog_gcd_fused_double_y +;;; + dialog_gcd_fused_halve_y are themselves ported (currently ABSENT +;;; per AUDIT §11 note). + +;; hclear: uncompute `h = a & b` (apply-phase fused double_y/halve_y). +;; HEAD config.rs:146. +(define *dgcd-fused-hclear-measured* #f) + +;; dclear: uncompute `d = ovf1 & s2` (apply-phase fused double_y). +;; Forward only -- in halve_y the matching `d` clear reads y[1] +;; after csub overwrite, so set-controls are no longer live. +;; HEAD config.rs:163. +(define *dgcd-fused-dclear-measured* #f) + +;; ovfclear: uncompute ovf1 / ovf2 cleanup ancillae using known mux +;; / AND expressions (apply-phase fused double_y). HEAD config.rs:172. +(define *dgcd-fused-ovfclear-measured* #f) + +;; halve_edclear: uncompute `e` and `d` in fused halve_y cleanup. +;; HEAD config.rs:179. +(define *dgcd-fused-halve-edclear-measured* #f) + +;; apply-final-windowed-fast-blocks: Option; #f = disabled, +;; integer >= 2 = block count. HEAD config.rs:183. +(define *dgcd-apply-final-windowed-fast-blocks* #f) + +;; apply-final-topclean-bits: usize; 0 = disabled. HEAD config.rs:190. +(define *dgcd-apply-final-topclean-bits* 0) + +;; apply-final-lowq: bool; HEAD config.rs:134 (dialog_gcd_apply_final +;; _lowq_enabled). Lowq variant for the final apply step. +(define *dgcd-apply-final-lowq* #f) + +;;; ── HEAD apply-chunked-f lever family ───────────────────────────── +;;; +;;; HEAD dialog/config.rs:71-131 defines 9 levers tuning the apply- +;;; phase chunked-f path. Closes AUDIT §9 rows 370-371. All default +;;; #f in lumbda. HEAD defaults reuse_cin_zero + fuse_boundary_clears +;;; ON; lumbda preserves byte-identity by defaulting them OFF. + +(define *dgcd-apply-chunked-f-blocks* #f) +(define *dgcd-apply-chunked-f-cut* #f) +(define *dgcd-apply-chunked-f-cut2* #f) +(define *dgcd-apply-chunked-f-cut3* #f) +(define *dgcd-apply-chunked-f-cut4* #f) +(define *dgcd-apply-chunked-f-custom4* #f) +(define *dgcd-apply-chunked-f-custom5* #f) +(define *dgcd-apply-chunked-f-reuse-cin-zero* #f) +(define *dgcd-apply-chunked-f-fuse-boundary-clears* #f) + +;;; ── apply-boundary-split lever ───────────────────────────────────── +;;; +;;; HEAD dialog/config.rs:190 (apply_boundary_split). Closes AUDIT §9 +;;; row 375 third option; the other two siblings (conditional_replay +;;; + replay_swap_host) PORTED earlier. + +(define *dgcd-apply-boundary-split* 0) + +;;; ── HEAD raw-tier lever family ───────────────────────────────────── +;;; +;;; HEAD dialog/config.rs:43-316. Closes AUDIT §9 rows 360-369 + 373-374. +;;; 19 default-OFF flag declarations covering raw-tier dispatch (tobitvector, +;;; ipmul, quotient, apply, pa-stop). Substrate wiring lives downstream: +;;; HEAD reads these via env vars in dialog/mod.rs's raw-path routers +;;; (round763 packer, ipmul block emit, quotient driver, apply phase +;;; truncated-clean variant). Lumbda byte-identity convention: all #f +;;; means current emit unchanged; cells that match HEAD's tuned route set +;;; the relevant flag #t. + +;; raw-apply-{direct,materialized}-special-add: HEAD config.rs:43,50. +;; Selects DIRECT vs MATERIALIZED special-add variants in raw-apply. +(define *dgcd-raw-apply-direct-special-add* #f) +(define *dgcd-raw-apply-materialized-special-add* #f) + +;; raw-apply-reverse-{fast-sub,materialized-special-sub}: HEAD config.rs:57,64. +;; Mirrors above for the reverse-direction apply sub-path. +(define *dgcd-raw-apply-reverse-fast-sub* #f) +(define *dgcd-raw-apply-reverse-materialized-special-sub* #f) + +;; reverse-branch-conditional-replay: HEAD config.rs:204. +(define *dgcd-reverse-branch-conditional-replay* #f) + +;; raw-tobitvector levers: HEAD config.rs:233,240,247. +(define *dgcd-raw-tobitvector-materialized-sub* #f) +(define *dgcd-raw-tobitvector-variable-width* #f) +(define *dgcd-raw-tobitvector-borrow-future-log-carries* #f) + +;; raw-ipmul / raw-quotient levers: HEAD config.rs:255-281. +;; raw-quotient-terminal-reuse falls back to raw-ipmul-terminal-reuse +;; in HEAD when its env var is unset; lumbda mirrors with a #f +;; sentinel meaning "fall through" — callers check raw-ipmul flag +;; if quotient flag is #f. +(define *dgcd-raw-ipmul-terminal-reuse* #f) +(define *dgcd-raw-ipmul-clear-p-residual* #f) +(define *dgcd-raw-quotient-terminal-reuse* #f) +(define *dgcd-raw-quotient-keep-terminal-u* #f) + +;; kcorr-route-via-primitive (sweep blackops 2026-06-11): when #t, +;; the host file's K-correction release/reacquire window routes +;; through dgcd-{release,reacquire}-terminal-vec! instead of raw +;; free!/alloc! calls. Today, runway=#f, byte-identical to raw +;; free!/alloc! sequence. Forward-compat with runway-aware partial +;; release (sweep-runway-layout follow-up). Default #f preserves +;; byte-identity for kcorrw0 + night17 champions. +(define *dgcd-kcorr-route-via-primitive* #f) + +;; raw-apply-truncated-clean: HEAD config.rs:283. +(define *dgcd-raw-apply-truncated-clean* #f) + +;; raw-pa-stop-* family: HEAD config.rs:290-315. Early-stop hooks +;; for the PA (point-add) driver after intermediate primitives, +;; used by HEAD's circuit-size measurement harness. +(define *dgcd-raw-pa-stop-after-quotient* #f) +(define *dgcd-raw-pa-stop-after-xtail* #f) +(define *dgcd-raw-pa-stop-after-c* #f) +(define *dgcd-raw-pa-stop-after-pair2* #f) + +;; compressed-sidecar-log: HEAD config.rs:327. +(define *dgcd-compressed-sidecar-log* #f) + +;;; ── dgcd-chunk-hi — sweep-dgcd-chunk-hi ─────────────────────────── +;;; +;;; HEAD dialog/mod.rs:1280 dialog_gcd_chunk_hi. Pure classical helper +;;; that computes the high-boundary index of chunk `block` (0-indexed) +;;; in a chunked-f apply pass with `blocks` total chunks over an +;;; `ext_n`-wide accumulator. Closes AUDIT row 410. +;;; +;;; Dispatch logic per HEAD: +;;; - blocks=4 + *dgcd-apply-chunked-f-custom4*: cuts at chunked-f- +;;; cut/cut2/cut3 (defaults ext_n/4, ext_n/2, 3*ext_n/4) +;;; - blocks=5 + *dgcd-apply-chunked-f-custom5*: cuts at chunked-f- +;;; cut/cut2/cut3/cut4 (defaults ext_n/5..4*ext_n/5) +;;; - block=0, blocks<=3: chunked-f-cut min ext_n-1 (default ext_n/2) +;;; - blocks=3, block=1: chunked-f-cut2 min ext_n-1 (default 2*ext_n/3) +;;; - else: ((block+1)*ext_n)/blocks (uniform partition) +;;; +;;; Flag-value contract: lumbda *dgcd-apply-chunked-f-cut*N* is #f for +;;; "use HEAD's default" or an integer for "use this value". Mirrors +;;; HEAD's Option exactly. The custom4/5 toggles are bool flags. + +(define (dgcd-chunk-hi blocks block ext-n) + "Port of HEAD dialog_gcd_chunk_hi (dialog/mod.rs:1280). Returns the + high-boundary index of the given chunk under chunked-f config." + (cond + ;; blocks=4 custom path + ((and (= blocks 4) *dgcd-apply-chunked-f-custom4*) + (let* ((c0 (or *dgcd-apply-chunked-f-cut* (quotient ext-n 4))) + (c1 (or *dgcd-apply-chunked-f-cut2* (quotient ext-n 2))) + (c2 (or *dgcd-apply-chunked-f-cut3* (quotient (* 3 ext-n) 4)))) + (cond + ((< block 3) + (cond ((= block 0) c0) + ((= block 1) c1) + (else c2))) + (else (quotient (* (+ block 1) ext-n) blocks))))) + ;; blocks=5 custom path + ((and (= blocks 5) *dgcd-apply-chunked-f-custom5*) + (let* ((c0 (or *dgcd-apply-chunked-f-cut* (quotient ext-n 5))) + (c1 (or *dgcd-apply-chunked-f-cut2* (quotient (* 2 ext-n) 5))) + (c2 (or *dgcd-apply-chunked-f-cut3* (quotient (* 3 ext-n) 5))) + (c3 (or *dgcd-apply-chunked-f-cut4* (quotient (* 4 ext-n) 5)))) + (cond + ((< block 4) + (cond ((= block 0) c0) + ((= block 1) c1) + ((= block 2) c2) + (else c3))) + (else (quotient (* (+ block 1) ext-n) blocks))))) + ;; block=0, blocks<=3 + ((and (= block 0) (<= blocks 3)) + (min (or *dgcd-apply-chunked-f-cut* (quotient ext-n 2)) + (- ext-n 1))) + ;; blocks=3, block=1 + ((and (= blocks 3) (= block 1)) + (min (or *dgcd-apply-chunked-f-cut2* (quotient (* 2 ext-n) 3)) + (- ext-n 1))) + ;; Uniform partition fallback + (else (quotient (* (+ block 1) ext-n) blocks)))) + +;;; ── dgcd-conditional-boundary-replay! — sweep-dgcd-chunk-hi ────── +;;; +;;; HEAD dialog/mod.rs:1323 dialog_gcd_conditional_boundary_replay. +;;; Closes AUDIT row 408. +;;; +;;; For each target in reverse order, HMR-uncompute the target bit + run +;;; cmp_lt_phase_conditioned_with_cin on the prefix u[start..p] / v[start..p], +;;; where start = previous-target's p (or 0 for first), carry_in = +;;; previous-target's qubit (or c_in for first). +;;; +;;; Caller responsibility: +;;; u-reg/v-reg: data registers width n +;;; ctrl-reg/ctrl-idx: external control +;;; cin-reg/cin-idx: initial carry-in bit +;;; targets: list of (target-reg target-idx p) triples; strictly +;;; ascending in p +;;; carries-reg/carries-offset + bit-base: scratch for the inner +;;; cmp-lt-phase-conditioned-with-cin! call + +(define (dgcd-conditional-boundary-replay! + c u-reg v-reg ctrl-reg ctrl-idx cin-reg cin-idx + targets carries-reg carries-offset) + "Port of HEAD dialog_gcd_conditional_boundary_replay (dialog/mod.rs:1323)." + (let loop ((idx (- (length targets) 1))) + (when (>= idx 0) + (let* ((cur (list-ref targets idx)) + (cur-tr (car cur)) + (cur-ti (cadr cur)) + (cur-p (caddr cur)) + (prev (if (= idx 0) + (list cin-reg cin-idx 0) + (list-ref targets (- idx 1)))) + (start (caddr prev)) + (carry-r (car prev)) + (carry-i (cadr prev)) + (phase-bit (+ 600000 idx))) + (gate-hmr! c cur-tr cur-ti phase-bit) + (cmp-lt-phase-conditioned-with-cin! + c u-reg v-reg (- cur-p start) + ctrl-reg ctrl-idx + carry-r carry-i + carries-reg carries-offset + phase-bit)) + (loop (- idx 1))))) + +;;; ── dgcd-pick-borrow-slice — sweep-dgcd-pick-borrow-slice ───────── +;;; +;;; HEAD dialog/mod.rs:457 dialog_gcd_pick_borrow_slice. Closes AUDIT +;;; row 411. Pure classical picker: chooses between a caller-supplied +;;; `future` borrow slice and a fallback slice carved from u's +;;; high-bits region. +;;; +;;; HEAD signature: Option<&[QubitId]> in, Option<&[QubitId]> out. +;;; Lumbda port returns a 3-tuple (reg, offset, length) when a slice +;;; is selected, or #f when nothing fits. Caller projects (reg, +;;; offset, length) into their slice consumers (e.g., +;;; cuccaro-add-fast-borrowed-lane!). +;;; +;;; Dispatch: +;;; - *dgcd-late-borrow-uv-high* must be #t AND active-width >= 1 +;;; - want = 2 * active-width - 1 +;;; - if future is shorter than want (or absent) AND u has enough +;;; room for active-width + want, return u[active-width.. +;;; active-width+want] +;;; - else return future as-is (may be #f). +;;; +;;; The `future` argument is itself a (reg, offset, length) triple or #f. + +(define (dgcd-pick-borrow-slice future u-reg u-len active-width) + "Port of HEAD dialog_gcd_pick_borrow_slice (dialog/mod.rs:457). + `future` is #f or a (reg offset length) list. Returns a (reg + offset length) list or #f." + (cond + ((and *dgcd-late-borrow-uv-high* (>= active-width 1)) + (let* ((want (- (* 2 active-width) 1)) + (short (or (not future) + (< (list-ref future 2) want)))) + (cond + ((and short (>= u-len (+ active-width want))) + (list u-reg active-width want)) + (else future)))) + (else future))) + +;;; ── selected-body lever family — sweep-selected-body-flags ──────── +;;; +;;; HEAD dialog/mod.rs:341,363,394,416,423,438. Closes AUDIT row 364 +;;; (selected-body-nocin) + adds the stream-suffix-map + body-host-cin +;;; flags + the per-step suffix-bits getter. +;;; +;;; All flags default OFF / 0 / empty. Downstream wiring lives in +;;; `dialog_gcd_controlled_sub_selected` (HEAD mod.rs:472) which is +;;; substrate work; this sweep makes the lever surface available. + +;; *dgcd-body-host-cin* — HEAD mod.rs:389. DIALOG_GCD_BODY_HOST_CIN. +;; Default OFF. When #t, materialized selected add/sub body sources +;; its c_in from a caller-supplied host register lane instead of +;; allocating fresh. +(define *dgcd-body-host-cin* #f) + +;; *dgcd-selected-body-nocin* — HEAD mod.rs:394. Integer 0/1/2. +;; 0 (#f): OFF (default) +;; 1: full no-cin path (drops c_in lane + folds carry into Cuccaro seed) +;; 2: keep-pool variant (no-cin body but legacy 2n-1 composite pool) +(define *dgcd-selected-body-nocin* 0) + +;; Helper: keep-pool predicate. HEAD mod.rs:416. +(define (dgcd-selected-body-nocin-keep-pool?) + (= *dgcd-selected-body-nocin* 2)) + +;; Helper: nocin-enabled predicate. HEAD mod.rs:405-408. +(define (dgcd-selected-body-nocin-enabled?) + (or (= *dgcd-selected-body-nocin* 1) + (= *dgcd-selected-body-nocin* 2))) + +;; *dgcd-selected-body-stream-suffix-map* — HEAD mod.rs:424. +;; DIALOG_GCD_SELECTED_BODY_STREAM_SUFFIX_MAP env var format +;; "step1:bits1,step2:bits2,...". Lumbda representation: alist +;; ((step . bits) ...). Default '() = empty map. +(define *dgcd-selected-body-stream-suffix-map* '()) + +(define (dgcd-selected-body-stream-suffix-bits step body-len) + "Port of HEAD dialog_gcd_selected_body_stream_suffix_bits + (mod.rs:423). Looks up `step` in the alist + clamps to body-len-1." + (let ((found (assq step *dgcd-selected-body-stream-suffix-map*))) + (cond + (found (min (cdr found) (max 0 (- body-len 1)))) + (else 0)))) + +(define (dgcd-selected-body-stream-top-enabled? step body-len) + "Port of HEAD dialog_gcd_selected_body_stream_top_enabled (mod.rs:438). + #t when the suffix-bits lookup returns exactly 1." + (= (dgcd-selected-body-stream-suffix-bits step body-len) 1)) + +;;; *dgcd-pa9024-compare-schedule* — HEAD's per-step comparator schedule +;;; (config.rs:390 `DIALOG_GCD_PA9024_COMPARE_SCHEDULE`). Replaces the +;;; flat `*dgcd-compare-bits*` with a 258-entry table tuned for the K=2 +;;; bounded-shift stack (active=258, WIDTH_SLOPE=1.014, WIDTH_MARGIN=10). +;;; Doc-comment from HEAD: "OBSERVED maximum req_cb = active_width +;;; - msb(u^v) ... measured over 8,000,000 reachable GCD factors ... +;;; under the active route (K2 double-shift)." +;;; +;;; HEAD's effective per-step cmp: +;;; scheduled = max(floor, schedule[step] + margin) min active_width +;;; effective = max(1, min(global_cmp, scheduled)) +;;; When the global cmp is tighter the schedule never relaxes; when it +;;; would over-tighten the schedule pulls toward HEAD's calibrated value. +;;; +;;; Defaults: flag OFF (use flat compare-bits), margin=0, floor=1. Setting +;;; the flag #t at K=2 stacks matches HEAD's production envelope. + +(define *dgcd-pa9024-compare-schedule* #f) +(define *dgcd-pa9024-compare-margin* 0) +(define *dgcd-pa9024-compare-floor* 1) + +;;; HEAD's DIALOG_GCD_PA9024_COMPARE_SCHEDULE verbatim (258 entries). +;;; Verified against /tmp/ecdsafail-challenge/src/point_add/rounds/dialog/ +;;; config.rs:390-402 commit 2dcf00d. Index = step. +(define *dgcd-pa9024-compare-schedule-table* + '#( 22 21 24 24 28 25 29 26 29 30 33 35 31 32 31 33 33 34 30 32 33 35 33 35 + 34 33 35 35 35 34 33 33 33 34 34 38 35 35 33 36 34 36 37 36 38 36 38 36 + 42 36 37 37 39 36 36 39 37 39 35 38 38 38 36 44 37 38 36 39 41 38 37 41 + 40 35 36 37 41 38 38 38 37 37 39 37 37 37 38 39 38 37 42 40 38 38 39 43 + 41 39 40 42 40 39 44 39 44 40 43 40 40 41 42 41 43 42 45 41 43 42 43 42 + 43 42 44 42 46 41 44 42 44 42 43 46 44 43 48 50 48 44 44 44 55 46 46 44 + 43 49 44 45 44 48 44 46 45 46 45 44 45 46 48 46 45 46 50 48 44 47 47 46 + 45 46 45 48 47 49 47 47 46 49 48 49 46 48 50 51 47 54 49 48 47 48 51 50 + 53 54 50 52 50 51 53 52 49 52 50 52 49 52 49 53 51 55 52 51 51 51 49 47 + 47 45 45 43 43 41 41 39 39 37 37 35 35 33 33 31 31 29 29 27 27 25 25 23 + 23 21 21 19 19 17 17 15 15 13 13 11 11 9 9 7 7 5)) + +(define (pa9024-schedule-lookup step) + "Returns the PA9024 schedule entry for `step`, or 0 if out of range + (HEAD falls back to global cmp via unwrap_or)." + (cond + ((< step 0) 0) + ((>= step (vector-length *dgcd-pa9024-compare-schedule-table*)) 0) + (else (vector-ref *dgcd-pa9024-compare-schedule-table* step)))) + +;;; *dgcd-late-borrow-uv-high* — HEAD's DIALOG_GCD_LATE_BORROW_UV_HIGH. +;;; +;;; When #t, ctrl-cuccaro-sub!/add! inside kaliski-iteration-dgcd! +;;; aliases u[uv-w..2*uv-w] as the masking ancilla instead of +;;; allocating a fresh uv-w-wide register. Engages only when +;;; 2 * uv-w <= n+1 (i.e., u has enough high zero space). Peak qubits +;;; drop by uv-w per engaged iter. Toffoli/Clifford counts identical +;;; (same gates, different target qubits). + +(define *dgcd-late-borrow-uv-high* #f) + +;;; *dgcd-odd-u-lowbit-fastpath* — HEAD's DIALOG_GCD_ODD_U_LOWBIT_FASTPATH. +;;; +;;; When #t, kaliski-iteration-dgcd! skips lane 0 in the cswap loop +;;; (since the cswap's controller a_f = (f AND NOT u[0]) is zero +;;; while u stays odd, so lane-0 cswap is a no-op anyway) and the +;;; lane-0 mask compute (since the body's controller add_f=1 +;;; implies both u and v_w are odd, so v_w[0]-=ctrl AND u[0] becomes +;;; v_w[0]^=add_f with no borrow into bit 1). Replaces lane-0 body +;;; with a single cx(add_f, v_w[0]). Saves 2 Toffoli + 4 Clifford +;;; per iter (cswap × 2) + 4 Toffoli + minor Clifford per iter +;;; (mask compute + cuccaro lane-0 + mask uncompute, both sub and +;;; add) and saves 1 peak qubit (mask is uv-w-1 wide instead of +;;; uv-w). Soundness gate at build time verifies u stays odd on +;;; every classically traced iteration. + +(define *dgcd-odd-u-lowbit-fastpath* #f) + +;;; *dgcd-body-carry-trunc-width* — HEAD DIALOG_GCD_BODY_CARRY_TRUNC_W. +;;; Mirrors HEAD `dialog_gcd_body_carry_trunc_width` at +;;; rounds/dialog/mod.rs:235-261: +;;; body_w = active_width.saturating_sub(trunc_w).max(2) +;;; Default #f = no trunc (byte-identical pre-sweep-051). +;;; +;;; Sweep-057: re-added after sweep-053 merge dropped a sweep-051 block +;;; that this branch's host.lsp still references (lines 269-271). Without +;;; this block, every emit invoking mod-inv-by-dialog-gcd-host! errors +;;; on a missing helper. + +(define *dgcd-body-carry-trunc-width* #f) + +;;; *dgcd-binder-notch-steps* — HEAD DIALOG_GCD_BINDER_NOTCH_STEPS. + +(define *dgcd-binder-notch-steps* (quote ())) + +;;; *dgcd-binder-notch-extra* — HEAD DIALOG_GCD_BINDER_NOTCH_EXTRA. + +(define *dgcd-binder-notch-extra* 0) + +;;; ── HEAD width helpers — sweep-width-helpers ────────────────────── +;;; +;;; HEAD dialog/mod.rs:200,212,223,246,264,276,288,316, +;;; +316/dialog_gcd_binder_notch_map_extra. +;;; +;;; Closes the width-helper substrate needed by composite-scratch + +;;; compressed-sidecar runway-layout. All pure classical helpers. + +;; *dgcd-body-carry-band-trims* — HEAD mod.rs:247 +;; DIALOG_GCD_BODY_CARRY_BAND_TRIMS env var format "trim1,trim2,...". +;; Lumbda: list of trims, '() = empty (no band-trim). +(define *dgcd-body-carry-band-trims* '()) + +;; *dgcd-tobitvector-cswap-body-trim* — HEAD mod.rs:264 +;; DIALOG_GCD_TOBITVECTOR_CSWAP_BODY_TRIM env var. When #t, cswap +;; uses body-carry-trunc-width. +(define *dgcd-tobitvector-cswap-body-trim* #f) + +;; *dgcd-tobitvector-shift-body-trim* — HEAD mod.rs:276 +;; DIALOG_GCD_TOBITVECTOR_SHIFT_BODY_TRIM env var. Same for shift. +(define *dgcd-tobitvector-shift-body-trim* #f) + +;; *dgcd-binder-notch-map-extra* — HEAD mod.rs:316 (referenced +;; from line 312). DIALOG_GCD_BINDER_NOTCH_MAP_EXTRA env var format +;; "step1:extra1,step2:extra2,...". Lumbda: alist of (step . extra). +(define *dgcd-binder-notch-map-extra* '()) + +;; *dgcd-trio-width-notch-step* + *_extra* already declared above +;; (sweep-fused-measured-flags era). + +(define (dgcd-width-margin) + "HEAD mod.rs:200 dialog_gcd_width_margin. Default 37.0; lumbda + stores integer via *dgcd-width-margin* (default 37)." + (exact->inexact *dgcd-width-margin*)) + +(define (dgcd-width-slope) + "HEAD mod.rs:212 dialog_gcd_width_slope. Default 0.5*1.415 = 0.7075; + lumbda stores per-thousand via *dgcd-width-slope-x1000* (default 708)." + (/ (exact->inexact *dgcd-width-slope-x1000*) 1000.0)) + +(define (dgcd-tobitvector-active-width step) + "HEAD mod.rs:223 dialog_gcd_tobitvector_active_width. Returns the + active width at the given step. When variable-width is OFF, returns + N=256." + (cond + ((not *dgcd-raw-tobitvector-variable-width*) 256) + (else + (let* ((ideal (+ (- 256.0 (* (exact->inexact step) (dgcd-width-slope))) + (dgcd-width-margin))) + (capped (max 1.0 ideal)) + (halved (ceiling (/ capped 2.0))) + (rounded (* 2 (inexact->exact halved)))) + (max 1 (min 256 rounded)))))) + +(define (dgcd-body-carry-band-trim step) + "HEAD mod.rs:246. Returns the per-step band trim from + *dgcd-body-carry-band-trims*, or #f when empty." + (cond + ((null? *dgcd-body-carry-band-trims*) #f) + (else + (let* ((iters (max 1 *dgcd-active-iters*)) + (trims-len (length *dgcd-body-carry-band-trims*)) + (band-size (max 1 (quotient (+ iters (- trims-len 1)) trims-len))) + (band (min (- trims-len 1) (quotient step band-size)))) + (list-ref *dgcd-body-carry-band-trims* band))))) + +(define (dgcd-binder-notch-map-extra-for step) + "HEAD mod.rs:316 dialog_gcd_binder_notch_map_extra. Looks up step in + the alist + returns the extra trim, or 0 when absent." + (let ((found (assq step *dgcd-binder-notch-map-extra*))) + (cond + (found (cdr found)) + (else 0)))) + +(define (dgcd-body-carry-trunc-width active-width step) + "HEAD mod.rs:288 dialog_gcd_body_carry_trunc_width. Full version + including band-trim + trio-notch + binder-notch + map-extra. + Supersedes dgcd-body-carry-trunc-width-for (kept below for ABI)." + (let* ((w0 (or (dgcd-body-carry-band-trim step) + (cond + (*dgcd-body-carry-trunc-width* + (cond + ((number? *dgcd-body-carry-trunc-width*) + *dgcd-body-carry-trunc-width*) + (else 0))) + (else 0)))) + (w1 (cond + ((and *dgcd-trio-width-notch-enabled* + (= step *dgcd-trio-width-notch-step*)) + (+ w0 *dgcd-trio-width-notch-extra*)) + (else w0))) + (w2 (cond + ((and (> *dgcd-binder-notch-extra* 0) + (member step *dgcd-binder-notch-steps*)) + (+ w1 *dgcd-binder-notch-extra*)) + (else w1))) + (w3 (+ w2 (dgcd-binder-notch-map-extra-for step)))) + (max 2 (- active-width w3)))) + +(define (dgcd-tobitvector-cswap-width active-width step) + "HEAD mod.rs:264 dialog_gcd_tobitvector_cswap_width." + (cond + (*dgcd-tobitvector-cswap-body-trim* + (min (dgcd-body-carry-trunc-width active-width step) active-width)) + (else active-width))) + +(define (dgcd-tobitvector-shift-width active-width step) + "HEAD mod.rs:276 dialog_gcd_tobitvector_shift_width." + (cond + (*dgcd-tobitvector-shift-body-trim* + (min (dgcd-body-carry-trunc-width active-width step) active-width)) + (else active-width))) + +;;; dgcd-body-carry-trunc-width-for — effective body width at step. +(define (dgcd-body-carry-trunc-width-for active-w step) + (cond + ((not *dgcd-body-carry-trunc-width*) active-w) + (else + (let* ((base-trim *dgcd-body-carry-trunc-width*) + (notch? (and (> *dgcd-binder-notch-extra* 0) + (member step *dgcd-binder-notch-steps*))) + (trim-w (if notch? + (+ base-trim *dgcd-binder-notch-extra*) + base-trim)) + (body-w (- active-w trim-w))) + (cond + ((< body-w 2) 2) + ((> body-w active-w) active-w) + (else body-w)))))) + +;;; *cmp-lt-with-cin* — sweep-053 Primitive 1. +;;; +;;; Mirrors HEAD's `cmp_lt_into_fast_with_cin` +;;; (point_add/arith/compare.rs:55-106). HEAD ships two variants: +;;; +;;; cmp_lt_into_fast — internally allocs cin (+1 peak qubit) +;;; cmp_lt_into_fast_with_cin — caller supplies cin from idle lane +;;; +;;; lumbda's existing cmp-lt-into-fast! (mod-arith.lsp:154) already takes +;;; cin-reg/cin-idx from caller, so its API matches HEAD's `with_cin`. The +;;; peak-qubit win HEAD captures comes from the CALLER borrowing cin from +;;; an idle operand lane instead of allocating a fresh qubit. +;;; +;;; At our dgcd-cmp-gt-into! hot site, the caller already passes cin-reg/ +;;; cin-idx via the borrowed-tmp path. When this flag is #t the call +;;; documentation marks the with-cin contract explicitly + the caller +;;; routes cin into the tmp-borrow tail (which is provably |0> at the +;;; comparator instant by the active-width clamp). Provides a regression +;;; checkpoint in case future primitives lose the with-cin invariant. +;;; +;;; Score-neutral when caller already supplies cin from idle lane +;;; (current dgcd-cmp-gt-into! does — gate sequence identical to the +;;; existing path); modest peak qubit save (1-3) at comparator instant +;;; if future call sites stop borrowing. +;;; +;;; Default #f = current behavior (no semantic-marker enforcement). When +;;; #t, also serves as a build-time assertion that the cin-reg passed in +;;; was sourced from a borrow rather than a fresh alloc — surfaces in +;;; logs if a substrate gap reintroduces the alloc path. +;;; +;;; HEAD's `assert!(!u.contains(&c_in))` invariant: we satisfy by +;;; keeping cin inside the borrowed carries register where (i) carries- +;;; reg is neither u-reg nor v-reg, AND (ii) the borrowed register tail +;;; bit is dead at the comparator instant. + +(define *cmp-lt-with-cin* #f) + +;;; cmp-lt-into-fast-with-cin! — HEAD's `cmp_lt_into_fast_with_cin` +;;; wrapper. Semantic-marker variant of cmp-lt-into-fast! emphasizing +;;; the caller-supplied cin contract. Body byte-identical — difference +;;; vs cmp_lt_into_fast lives at the CALL SITE (cin chosen from an idle +;;; lane, not freshly alloced). Provided so future call sites that opt +;;; into the *cmp-lt-with-cin* discipline can signal intent in source. + +(define (cmp-lt-into-fast-with-cin! c u-reg v-reg n + flag-reg flag-idx cin-reg cin-idx + carries-reg carries-offset bit-base) + "Caller-supplied-cin variant of cmp-lt-into-fast! (HEAD compare.rs:55). + Identical gate sequence; the discipline is that cin-reg/cin-idx must + point into an idle operand lane the caller BORROWED rather than fresh- + allocated. carries-reg[carries-offset..+n) must be |0> in/out via the + HMR backward sweep. bit-base..+n-1 reserves classical bits." + (cmp-lt-into-fast! c u-reg v-reg n + flag-reg flag-idx cin-reg cin-idx + carries-reg carries-offset bit-base)) + +;;; ── width envelope helpers ──────────────────────────────────────── + +;;; ceiling-div — ceiling(a / b) for positive a, b. + +(define (dgcd-ceiling-div a b) + (quotient (+ a (- b 1)) b)) + +;;; dgcd-uv-width — smooth linear envelope per step. +;;; +;;; Ports HEAD's `dialog_gcd_tobitvector_active_width` at +;;; mod.rs:24452-24459. The `2 * ceiling(ideal / 2)` keeps the width +;;; even (HEAD's comparator/cuccaro family is even-width-friendly). +;;; We clamp at 1 below & n+1 above so the helper never returns a +;;; degenerate width. +;;; +;;; To stay integer-only inside lumbda we scale by 1000: +;;; ideal × 1000 = N×1000 - step × slope-x1000 + margin × 1000 +;;; then divide by 1000 with ceiling for the final width-half. + +;;; *dgcd-trio-width-notch-enabled* / -step / -extra ──────────────── +;;; +;;; HEAD's DIALOG_GCD_TRIO_WIDTH_NOTCH lever family (dialog/mod.rs:376-394). +;;; HEAD's docstring on the enabled flag: "Default-on successor from +;;; aaf9616: the current route inherited its body geometry, and this +;;; one-step notch is needed to reclaim the 1306q tier." sweep-026 §2 +;;; flagged this as a knob HEAD's a66b042 frontier uses. +;;; +;;; What it does: adds `*dgcd-trio-width-notch-extra*` to the active +;;; width at exactly step = `*dgcd-trio-width-notch-step*`. HEAD's +;;; defaults: enabled=#t, step=11, extra=2. +;;; +;;; AUDIT §9 lever row 368. Default-OFF in lumbda to preserve byte- +;;; identity for existing cells; cells that want HEAD's default +;;; behavior MUST explicitly set *dgcd-trio-width-notch-enabled* #t. +;;; (HEAD env-default-on vs lumbda flags-default-off is a deliberate +;;; convention difference -- per CLAUDE.md "merge-to-master rule": +;;; flags default OFF, primitives are additive, never modify existing +;;; behavior.) HEAD's step + extra defaults are preserved so the +;;; behavior on opt-in matches HEAD. + +(define *dgcd-trio-width-notch-enabled* #f) +(define *dgcd-trio-width-notch-step* 11) +(define *dgcd-trio-width-notch-extra* 2) + +;;; ── Missing HEAD submission-route flags — sweep-missing-route-flags +;;; +;;; Dialog-side flags missing from lumbda. All default OFF / sentinel. + +;; *dgcd-branch-bits-host-comparator* — HEAD mod.rs:69 +;; DIALOG_GCD_BRANCH_BITS_HOST_COMPARATOR. Routes the fused branch-bit +;; path through borrowed-carry comparator on future-log slice instead +;; of allocating cmp ancilla. 1466 -> peak-cut substrate lever. +(define *dgcd-branch-bits-host-comparator* #f) + +;; *dgcd-measured-apply-sub* — HEAD mod.rs:1186 (DIALOG_GCD_MEASURED_APPLY_SUB). +;; Gidney measurement uncompute for apply-phase modular subtract's raw +;; difference. ~n Toffoli instead of ~2n per call; peak-neutral. +(define *dgcd-measured-apply-sub* #f) + +;; *dgcd-raw-pa* — HEAD mod.rs:1106 (DIALOG_GCD_RAW_PA). +;; Master toggle for raw point-add path. +(define *dgcd-raw-pa* #f) + +;; *dgcd-measured-underflow-gate* — HEAD mod.rs:1056 +;; DIALOG_GCD_MEASURED_UNDERFLOW_GATE. Measured uncompute for the +;; underflow comparator gate. +(define *dgcd-measured-underflow-gate* #f) + +;; *mod-fast-flag-conditional-replay* — HEAD mod.rs:1105 +;; MOD_FAST_FLAG_CONDITIONAL_REPLAY. Routes mod_add_qq_fast's flag +;; uncompute through cmp_lt_phase_conditioned (HMR-vented) instead of +;; cmp_lt_into_fast. Saves the load_const transient. +(define *mod-fast-flag-conditional-replay* #f) + +;; *dgcd-free-scratch-before-shift* — HEAD mod.rs:1314 +;; DIALOG_GCD_FREE_SCRATCH_BEFORE_SHIFT. Bennett-frees composite scratch +;; before the shift phase, reducing peak. +(define *dgcd-free-scratch-before-shift* #f) + +;; *dgcd-special-overflow-clean-step-bits* — HEAD mod.rs:1285 +;; DIALOG_GCD_SPECIAL_OVERFLOW_CLEAN_STEP_BITS env "step:bits,..." map. +;; Per-step overflow-clean comparator width override. Lumbda: alist. +(define *dgcd-special-overflow-clean-step-bits* '()) + +;; *dgcd-special-underflow-clean-step-bits* — HEAD mod.rs:1289 +;; Symmetric for underflow-clean. Lumbda: alist. +(define *dgcd-special-underflow-clean-step-bits* '()) + +(define (dgcd-uv-width-raw step n+1) + "HEAD-formula raw active width for `step`. Returns even integer in + [2, n+1] (even because HEAD's family is even-width-friendly). step + = 0 returns ~ n + MARGIN, monotone-decreasing thereafter. + + sweep-trio-width-notch (2026-06-10): applies the HEAD trio-width- + notch one-step bump when *dgcd-trio-width-notch-enabled* AND step + matches the configured notch step. Adds *dgcd-trio-width-notch- + extra* to the active width AT that step only, then resumes the + baseline envelope. Maintains the even-rounded clamp." + (let* ((n (- n+1 1)) + (n-times-1000 (* n 1000)) + (step-slope (* step *dgcd-width-slope-x1000*)) + (margin-x1000 (* *dgcd-width-margin* 1000)) + (ideal-x1000 (+ (- n-times-1000 step-slope) margin-x1000)) + (ideal-x1000+ (if (< ideal-x1000 1000) 1000 ideal-x1000)) + (half-ceil (dgcd-ceiling-div ideal-x1000+ 2000)) + (rounded (* 2 half-ceil)) + ;; Apply trio-width-notch bump at the configured step. + (notch-extra (cond + ((and *dgcd-trio-width-notch-enabled* + (= step *dgcd-trio-width-notch-step*)) + *dgcd-trio-width-notch-extra*) + (else 0))) + (with-notch (+ rounded notch-extra)) + (clamped-hi (if (> with-notch n+1) n+1 with-notch)) + (clamped-lo (if (< clamped-hi 2) 2 clamped-hi))) + clamped-lo)) + +;;; dgcd-compare-bits-for-step — comparator window per step. +;;; +;;; HEAD's `dialog_gcd_compare_bits_for_step` (mod.rs:24290) compares +;;; only the top `min(*dgcd-compare-bits*, active-width)` bits. When +;;; *dgcd-compare-bits* is #f we use the full active width (no +;;; truncation). + +(define (dgcd-compare-bits-for-step step n+1) + (let* ((active (dgcd-uv-width-raw step n+1)) + (n (- active 1)) + (global (cond + ((not *dgcd-compare-bits*) n) + ((>= *dgcd-compare-bits* n) n) + ((< *dgcd-compare-bits* 1) 1) + (else *dgcd-compare-bits*)))) + ;; HEAD's compare_bits_for_step (dialog_gcd_classical_filter.rs:133): + ;; when pa9024_compare_schedule is set, look up schedule[step], add + ;; margin, clamp to [floor, active]; the final result is min'd with + ;; the global cmp + max'd with 1 so the schedule can only TIGHTEN. + (cond + ((not *dgcd-pa9024-compare-schedule*) global) + (else + (let* ((raw (pa9024-schedule-lookup step)) + (with-marg (+ raw *dgcd-pa9024-compare-margin*)) + (floored (max with-marg *dgcd-pa9024-compare-floor*)) + (capped (min floored n)) + (scheduled (min capped global))) + (max 1 scheduled)))))) + +;;; dgcd-resolve-iters — concrete iteration count to use. +;;; +;;; #f means full textbook 2n; integer is the capped value (clamped +;;; into [1, 2n] to defend against absurd values). + +(define (dgcd-resolve-iters n+1) + (let ((textbook (* 2 (- n+1 1)))) + (cond + ((not *dgcd-active-iters*) textbook) + ((> *dgcd-active-iters* textbook) textbook) + ((< *dgcd-active-iters* 1) 1) + (else *dgcd-active-iters*)))) + +;;; ── truncated comparator wrapper ──────────────────────────────── + +;;; dgcd-cmp-gt-into! — flag ^= (u[top..] > v[top..]) over compare-bits. +;;; +;;; Mirrors HEAD's `dialog_gcd_cmp_gt_truncated_into_width`. When +;;; compare-bits = active width this collapses to the standard +;;; cmp-gt-into!. When narrower, we slice both operands to their top +;;; compare-bits suffix (HEAD's "start = u.len() - compare_bits"). +;;; +;;; lumbda's cmp-lt-into! / cmp-gt-into! reads bit-by-bit by integer +;;; index into the register. We pass `n` = compare-bits and rely on +;;; the comparator to read indices [0..n-1]. Since the active-width +;;; truncation guarantees bits above active are |0>, comparing the +;;; LOW compare-bits gives the WRONG answer in general (we want the +;;; top); rebind by aliasing to a shifted view is awkward in our +;;; substrate. +;;; +;;; DECISION for v1: take the comparator over the LOW compare-bits. +;;; Sound? Only if u, v have known-zero high bits AND the low +;;; compare-bits suffice to determine the comparison. On the +;;; verifier-reachable support after sufficiently many iters, both +;;; u and v are small enough to fit in compare-bits — so the LOW +;;; truncation is value-exact then. EARLY iters where u or v exceeds +;;; 2^compare-bits would give the wrong comparator. So: +;;; +;;; guard: only truncate when active-width <= compare-bits, else +;;; fall through to full active-width comparator. +;;; +;;; This is more conservative than HEAD's TOP-bits truncation but +;;; gives the same Toffoli savings on the late-step support (where +;;; HEAD's win is concentrated). For TOP-bits we'd need a sliced- +;;; register view primitive that mod-arith does not currently expose. + +;;; *dgcd-host-comparator* — sweep-hosted-cmp-wire flag. +;;; +;;; When #t, dgcd-cmp-gt-into! compares the TOP cmp-bits of u and v +;;; (HEAD's HOSTED semantics: cmp over u[start..] / v[start..] where +;;; start = active-width - cmp-bits) instead of the LOW cmp-bits +;;; (current default which can mis-decide when low bits of GCD operands +;;; differ but high bits don't — caught by Fiat-Shamir reroll). +;;; +;;; Routes through cmp-lt-into-fast-offset! (sweep-prefix-targets-split). +;;; Saves no Toffolis per call vs the low-bit path, but the TOP-bit +;;; semantics matches HEAD's tuned route + makes the comparator more +;;; reliable at tight width margins (fewer reroll hazards). +;;; +;;; Default #f preserves the current low-bit behavior + champion +;;; byte-identity. +(define *dgcd-host-comparator* #f) + +(define (dgcd-cmp-gt-into! c u-reg v-reg active-width step + flag-reg flag-idx cin-reg cin-idx + . tmp-borrow-opt) + "flag ^= (u > v) at the active comparator width for `step`. + Defers to cmp-gt-into! over the appropriate width. + When *cuccaro-use-borrowed* is #t & tmp-borrow-opt supplies a + register name, uses cmp-lt-into-fast! (HMR uncompute, saves n CCX + per call). Arg swapped (v u) to convert > → < per cmp-gt-into!'s + contract. + + sweep-hosted-cmp-wire: when *dgcd-host-comparator* is #t AND + *cuccaro-use-borrowed* is #t AND tmp-borrow-opt is supplied, + routes through cmp-lt-into-fast-offset! at TOP-bit slice + (u[start..] / v[start..] where start = active-width - cmp-bits). + Matches HEAD's HOSTED comparator semantics." + (let ((cmp-w (cond + ((not *dgcd-compare-bits*) active-width) + ((>= *dgcd-compare-bits* active-width) active-width) + (else *dgcd-compare-bits*)))) + (cond + ((and *dgcd-host-comparator* + *cuccaro-use-borrowed* + (not (null? tmp-borrow-opt))) + ;; HOSTED top-bit comparator (sweep-hosted-cmp-wire). + (let ((start (- active-width cmp-w))) + (cmp-lt-into-fast-offset! c v-reg start u-reg start cmp-w + flag-reg flag-idx cin-reg cin-idx + (car tmp-borrow-opt) 0 + (* 4 active-width)))) + ((and *cuccaro-use-borrowed* (not (null? tmp-borrow-opt))) + (cmp-lt-into-fast! c v-reg u-reg cmp-w + flag-reg flag-idx cin-reg cin-idx + (car tmp-borrow-opt) 0 (* 4 active-width))) + (else + (cmp-gt-into! c u-reg v-reg cmp-w + flag-reg flag-idx cin-reg cin-idx))))) + +;;; ── dgcd-ccx-cmp-gt-truncated-into-width-hosted! ───────────────── +;;; +;;; Port of HEAD dgcd_ccx_cmp_gt_truncated_into_width_hosted +;;; dialog/mod.rs:83-123, commit 2dcf00d. THE single biggest score +;;; lever HEAD has that we lack -- per sweep-026 section 2, HEAD's +;;; a66b042 frontier uses CLEAN_COMPARE_BITS=20 + the HOSTED +;;; comparator path to land its 1309q route's score advantage. +;;; +;;; What HOSTED does: comparator over a TRUNCATED top-bit window +;;; ( u[start..], v[start..] where start = active-width - compare-bits ) +;;; with the c-in + carries lanes BORROWED from a transient +;;; future-log prefix that's idle at the comparator's instant. Three +;;; dispatch modes per HEAD lines 108-121: +;;; +;;; (a) PARTIAL-HOST: borrowed available > 0 but < need; allocate +;;; only the deficit, prepend borrowed prefix, call +;;; borrowed-carries on the gathered lane. Saves the peak +;;; qubit that an all-or-nothing alloc would pin at the late- +;;; step branch_bits instant. Requires the partial-host flag. +;;; +;;; (b) FULL-HOST: borrowed >= need; no own-alloc, call borrowed- +;;; carries directly on the borrowed prefix. +;;; +;;; (c) NO-HOST: no borrowed lane available; alloc fresh cin + +;;; carries, call borrowed-carries (HEAD calls +;;; ccx_cmp_lt_into_fast directly, but lumbda's only standalone +;;; ccx variant IS borrowed-carries so we route through it). +;;; +;;; Argument swap (cmp_u = v, cmp_v = u) converts > -> < matching +;;; HEAD's pattern + our dgcd-cmp-gt-into!'s convention. +;;; +;;; Lumbda signature mirrors HEAD via offset/length triples since +;;; lumbda lacks slice types. The borrowed lane is encoded as +;;; (borrowed-reg, borrowed-off, borrowed-len); pass borrowed-reg=#f +;;; to indicate no borrowed lane (NO-HOST mode). +;;; +;;; Substrate status: ADDITIVE. No lumbda caller dispatches through +;;; this primitive yet. Wired into a callsite by a follow-on sweep +;;; that ports the dialog-gcd branch-bit comparator HOSTED path +;;; (HEAD dialog/mod.rs:303-360 region; uses this primitive at the +;;; per-step comparator instant). +;;; +;;; HEAD-PARITY-COLLAB section 1.2 row 7 closes with this port. + +(define *dgcd-partial-host-comparator* #f) + +(define (dgcd-ccx-cmp-gt-truncated-into-width-hosted! + c u-reg v-reg active-width + ctrl-reg ctrl-idx target-reg target-idx + compare-bits + borrowed-reg borrowed-off borrowed-len + carries-fallback-reg carries-fallback-off + cin-fallback-reg cin-fallback-idx + bit-base) + ;; HOSTED truncated > comparator. See header. + ;; Caller supplies fallback cin + carries lanes that get used in + ;; NO-HOST mode (lumbda alloc happens at caller scope, not inline). + ;; PARTIAL-HOST mode would need an additional own-alloc deficit + ;; lane the caller pre-stages; for v1 we conservatively fall back + ;; to FULL-HOST when borrowed >= need, else NO-HOST. The PARTIAL + ;; flag + deficit-alloc path is a follow-on sweep so the dispatcher + ;; lands clean here. + (let* ((cmp-bits (max 1 (min compare-bits active-width))) + (start (- active-width cmp-bits)) + (need (+ cmp-bits 1))) + (cond + ;; FULL-HOST: borrowed available + sufficient. + ((and borrowed-reg (>= borrowed-len need)) + ;; Borrowed slot 0 = c_in; slots 1..cmp-bits = carries. + (ccx-cmp-lt-into-fast-borrowed-carries-offset! + c v-reg start u-reg start cmp-bits + ctrl-reg ctrl-idx target-reg target-idx + borrowed-reg (+ borrowed-off 1) + borrowed-reg borrowed-off + bit-base)) + ;; NO-HOST / PARTIAL fallback (PARTIAL deficit-alloc TODO). + (else + (ccx-cmp-lt-into-fast-borrowed-carries-offset! + c v-reg start u-reg start cmp-bits + ctrl-reg ctrl-idx target-reg target-idx + carries-fallback-reg carries-fallback-off + cin-fallback-reg cin-fallback-idx + bit-base))))) + +;;; ── dgcd-clean-truncated-underflow! ──────────────────────────────── +;;; +;;; Port of HEAD dialog_gcd_clean_truncated_underflow +;;; (src/point_add/rounds/dialog/mod.rs:1173-1206, commit 2dcf00d). +;;; Special-purpose helper inside HEAD's apply-phase that conditionally +;;; clears acc_ovf when the truncated-top comparator says acc < a. +;;; +;;; HEAD's two dispatch paths: +;;; (a) special_clean_conditional_replay_enabled: HMR(acc_ovf) + +;;; z_if(ctrl, phase) + phase-conditioned comparator. The +;;; conditional replay only fires on the half-shots where HMR +;;; projected acc_ovf to 1. +;;; (b) plain: cx(ctrl, acc_ovf) + ccx_cmp_lt_into_fast on the top +;;; compare-bits slice. +;;; +;;; Both paths bracketed by negate-u envelope (X on a[compare_start..]). +;;; +;;; Substrate status: ADDITIVE. No lumbda caller dispatches yet. +;;; Closes AUDIT §10 dialog_gcd_clean_truncated_underflow ABSENT row. +;;; Lumbda caller integration is a follow-on sweep that wires +;;; dgcd-special-clean-conditional-replay flag into apply-phase +;;; emit. Path (a) routes through `cmp-lt-phase-conditioned-with-cin!` +;;; (PORTED, offset-indexed variant at mod-arith.lsp:703). Path (b) +;;; routes through `ccx-cmp-lt-into-fast-borrowed-carries-offset!` +;;; (PORTED via sweep-hosted-comparator at mod-arith.lsp). + +(define *dgcd-special-clean-conditional-replay* #f) + +(define (dgcd-special-underflow-clean-compare-bits step) + ;; HEAD dialog/config.rs:dialog_gcd_special_underflow_clean_compare_bits + ;; — per-step compare-bits for the underflow-clean comparator. Default + ;; falls back to the global *dgcd-compare-bits*. step argument matches + ;; HEAD's Option; pass #f for global default. + (cond + ((not step) (or *dgcd-compare-bits* 56)) ; HEAD's flat default at production + (else (or *dgcd-compare-bits* 56)))) + +(define (dgcd-clean-truncated-underflow! + c acc-reg a-reg active-width + ctrl-reg ctrl-idx + acc-ovf-reg acc-ovf-idx + step + ;; Path (a) ancilla: cin for phase-conditioned, phase-bit ID, + ;; bit-base for window-inverse HMR; carries for the inner + ;; phase-conditioned window pair. + phase-cin-reg phase-cin-idx + phase-bit + phase-carries-reg phase-carries-off + phase-bit-base + ;; Path (b) ancilla: borrowed-carries-offset's carries + cin + ;; + bit-base. Only one of (a)/(b) ancilla pairs is consumed + ;; per call; caller may pass dummy values for the unused + ;; path. + plain-carries-reg plain-carries-off + plain-cin-reg plain-cin-idx + plain-bit-base) + ;; HEAD lines 1181-1205 with two dispatch paths gated by + ;; *dgcd-special-clean-conditional-replay*. + (let* ((cmp-bits (dgcd-special-underflow-clean-compare-bits step)) + (compare-start (- active-width cmp-bits))) + ;; (1) Negate the top slice of a (HEAD: for &q in &a[compare_start..]: b.x(q)). + (let loop ((i compare-start)) + (when (< i active-width) + (gate-x! c a-reg i) + (loop (+ i 1)))) + ;; (2) Dispatch. + (cond + (*dgcd-special-clean-conditional-replay* + ;; Path (a): HMR + z_if + phase-conditioned comparator. + ;; HEAD lines 1186-1198. + (gate-hmr! c acc-ovf-reg acc-ovf-idx phase-bit) + ;; z_if(ctrl, phase): in lumbda, push-cond + cz + pop-cond. + ;; z_if(q, c) emits an X+CZ+X identity at small width but + ;; the lumbda primitive sequence captures the same semantics + ;; via the phase-bit gating. + (gate-push-cond! c phase-bit) + (gate-cz! c ctrl-reg ctrl-idx ctrl-reg ctrl-idx) + (gate-pop-cond! c) + (cmp-lt-phase-conditioned-with-cin! + c acc-reg compare-start a-reg compare-start cmp-bits + phase-cin-reg phase-cin-idx + ctrl-reg ctrl-idx + phase-bit + phase-carries-reg phase-carries-off + phase-bit-base)) + (else + ;; Path (b): plain cx + ccx_cmp_lt_into_fast. + ;; HEAD lines 1200-1201. + (gate-cx! c ctrl-reg ctrl-idx acc-ovf-reg acc-ovf-idx) + (ccx-cmp-lt-into-fast-borrowed-carries-offset! + c acc-reg compare-start a-reg compare-start cmp-bits + ctrl-reg ctrl-idx acc-ovf-reg acc-ovf-idx + plain-carries-reg plain-carries-off + plain-cin-reg plain-cin-idx + plain-bit-base))) + ;; (3) Un-negate the top slice of a. + (let loop ((i compare-start)) + (when (< i active-width) + (gate-x! c a-reg i) + (loop (+ i 1)))))) + +;;; ── v2 helpers: LATE_BORROW + ODD_U lane-0 fastpath ────────────── +;;; +;;; ccx-mask-offset! — like ccx-mask! but with offsets on src & dst. +;;; +;;; Walks k in [body-start, body-end) emitting +;;; ccx(ctrl, src[src-off+k], dst[dst-off+k]) +;;; Self-inverse on the (ctrl, src) inputs; uncomputes by replaying. + +(define (dgcd-ccx-mask-offset! c ctrl-reg ctrl-idx + src-reg src-off + dst-reg dst-off + body-start body-end) + (let loop ((k body-start)) + (when (< k body-end) + (gate-ccx! c ctrl-reg ctrl-idx + src-reg (+ src-off k) + dst-reg (+ dst-off k)) + (loop (+ k 1))))) + +;;; dgcd-ctrl-cuccaro-sub-extended! — substrate-faithful sub with the +;;; LATE_BORROW + ODD_U knobs applied. +;;; +;;; Effect (over uv-w bits): +;;; acc[..uv-w] := acc[..uv-w] - (ctrl ? u[..uv-w] : 0) mod 2^uv-w +;;; +;;; Knob semantics: +;;; borrow? = #t — host the masking ancilla on u[uv-w..2*uv-w] (which +;;; is guaranteed |0> when 2*uv-w <= n+1 by the width- +;;; truncation premise). When #f, allocate a fresh +;;; uv-w-wide register named mask-name as before. +;;; odd-u? = #t — skip lane 0 of the mask compute & cuccaro body; +;;; emit a single (gate-cx ctrl acc[0]) instead. Body +;;; runs over bits 1..uv-w-1. +;;; +;;; Caller must guarantee: +;;; - When borrow? = #t: 2 * uv-w <= n+1 (so u[uv-w..2*uv-w] exists). +;;; u[uv-w..2*uv-w] must be |0> on entry (truncation premise). +;;; Returns |0> on exit. +;;; - When odd-u? = #t: ctrl ⇒ (u[0] = 1) AND (acc[0] = ctrl). When +;;; ctrl = 0 the lane-0 body is a no-op; when ctrl = 1 we have +;;; acc[0] - u[0] = ctrl - 1 = 0 with no borrow into bit 1. +;;; +;;; cuccaro-sub-offset! n=1 special-cases to (cx a[0] acc[0])(cx cin +;;; acc[0]); we never enter the n=1 sub-body when odd-u? is on because +;;; the body starts at bit 1. + +(define (dgcd-ctrl-cuccaro-sub-extended! c + ctrl-reg ctrl-idx + u-reg uv-w n+1 + acc-reg + cin-reg cin-idx + mask-name + borrow? odd-u?) + (let* ((mask-w (if odd-u? (- uv-w 1) uv-w)) + (body-start (if odd-u? 1 0)) + (body-end uv-w) + (mask-host u-reg) + (mask-off uv-w)) + ;; Allocate or alias the mask scratch. + (cond + (borrow? + ;; Aliasing u[uv-w..uv-w+mask-w] as the mask. Requires + ;; uv-w + mask-w <= n+1 (caller-side guard). + (when (> (+ uv-w mask-w) n+1) + (error "dgcd-ctrl-cuccaro-sub-extended!: borrow? requires " + "uv-w + mask-w <= n+1; uv-w=" uv-w + " mask-w=" mask-w " n+1=" n+1))) + (else + (alloc! c mask-name mask-w))) + ;; ── compute mask = ctrl AND u over [body-start, body-end) ── + (cond + (borrow? + ;; mask lives at u[uv-w + (k - body-start)]; src is u[k] + (let loop ((k body-start)) + (when (< k body-end) + (gate-ccx! c ctrl-reg ctrl-idx + u-reg k + mask-host (+ uv-w (- k body-start))) + (loop (+ k 1))))) + (else + ;; mask-name lives at index (k - body-start) + (let loop ((k body-start)) + (when (< k body-end) + (gate-ccx! c ctrl-reg ctrl-idx + u-reg k + mask-name (- k body-start)) + (loop (+ k 1)))))) + ;; ── odd-u lane-0 contribution: acc[0] ^= ctrl ── + (when odd-u? + (gate-cx! c ctrl-reg ctrl-idx acc-reg 0)) + ;; ── cuccaro-sub-offset over the mask body ── + (when (> mask-w 0) + (cond + (borrow? + (cuccaro-sub-offset! c mask-host uv-w acc-reg body-start + cin-reg cin-idx mask-w)) + (else + (cuccaro-sub-offset! c mask-name 0 acc-reg body-start + cin-reg cin-idx mask-w)))) + ;; ── uncompute mask (ccx self-inverse) ── + (cond + (borrow? + (let loop ((k body-start)) + (when (< k body-end) + (gate-ccx! c ctrl-reg ctrl-idx + u-reg k + mask-host (+ uv-w (- k body-start))) + (loop (+ k 1))))) + (else + (let loop ((k body-start)) + (when (< k body-end) + (gate-ccx! c ctrl-reg ctrl-idx + u-reg k + mask-name (- k body-start)) + (loop (+ k 1)))))) + ;; ── free the mask register if we allocated it ── + (when (not borrow?) + (free! c mask-name)))) + +(define (dgcd-ctrl-cuccaro-add-extended! c + ctrl-reg ctrl-idx + u-reg uv-w n+1 + acc-reg + cin-reg cin-idx + mask-name + borrow? odd-u?) + "Inverse of dgcd-ctrl-cuccaro-sub-extended!: acc += ctrl ? u : 0 + mod 2^uv-w. Same borrow / odd-u semantics. Used in the s-side + r-cuccaro-add slot, where the soundness premise on odd-u differs + (r and s do NOT carry a binary-GCD oddness invariant) — caller + must therefore NOT set odd-u? = #t when this helper is applied to + r/s. The kaliski-iteration-dgcd! call sites enforce this." + (let* ((mask-w (if odd-u? (- uv-w 1) uv-w)) + (body-start (if odd-u? 1 0)) + (body-end uv-w) + (mask-host u-reg)) + (cond + (borrow? + (when (> (+ uv-w mask-w) n+1) + (error "dgcd-ctrl-cuccaro-add-extended!: borrow? requires " + "uv-w + mask-w <= n+1; uv-w=" uv-w + " mask-w=" mask-w " n+1=" n+1))) + (else + (alloc! c mask-name mask-w))) + (cond + (borrow? + (let loop ((k body-start)) + (when (< k body-end) + (gate-ccx! c ctrl-reg ctrl-idx + u-reg k + mask-host (+ uv-w (- k body-start))) + (loop (+ k 1))))) + (else + (let loop ((k body-start)) + (when (< k body-end) + (gate-ccx! c ctrl-reg ctrl-idx + u-reg k + mask-name (- k body-start)) + (loop (+ k 1)))))) + (when odd-u? + (gate-cx! c ctrl-reg ctrl-idx acc-reg 0)) + (when (> mask-w 0) + (cond + (borrow? + (cuccaro-add-offset! c mask-host uv-w acc-reg body-start + cin-reg cin-idx mask-w)) + (else + (cuccaro-add-offset! c mask-name 0 acc-reg body-start + cin-reg cin-idx mask-w)))) + (cond + (borrow? + (let loop ((k body-start)) + (when (< k body-end) + (gate-ccx! c ctrl-reg ctrl-idx + u-reg k + mask-host (+ uv-w (- k body-start))) + (loop (+ k 1))))) + (else + (let loop ((k body-start)) + (when (< k body-end) + (gate-ccx! c ctrl-reg ctrl-idx + u-reg k + mask-name (- k body-start)) + (loop (+ k 1)))))) + (when (not borrow?) + (free! c mask-name)))) + +;;; dgcd-borrow-engages? — gate function for LATE_BORROW per iter. +;;; +;;; HEAD's pick_borrow_slice falls back to u-high only when the +;;; compressed future log is short. Our substrate has no future log; +;;; we engage whenever the width-truncation envelope leaves enough +;;; high-zero space on u. + +(define (dgcd-borrow-engages? uv-w n+1 odd-u-on?) + (let ((mask-w (if odd-u-on? (- uv-w 1) uv-w))) + (and *dgcd-late-borrow-uv-high* + (>= mask-w 1) + (<= (+ uv-w mask-w) n+1)))) + +;;; ── one Kaliski iteration with dialog-gcd width schedule ──────── + +;;; kaliski-iteration-dgcd! — clone of kaliski-iteration-trunc! but +;;; with the smooth envelope and truncated comparator. +;;; +;;; Identical control flow to kaliski-iteration-trunc! +;;; (mod-inv-by.lsp:1046); only the width helpers change. We name +;;; iteration-local ancillae with a "dg-" prefix so allocator names +;;; don't collide with concurrently-built kaliski-iteration-trunc! +;;; circuits inside the same emitter (defensive — no current call +;;; site mixes them). + +(define (kaliski-iteration-dgcd! c iter-idx n+1 p + u-name v-w-name r-name s-name + f-name f-idx + m-hist-name m-idx + cin-name cin-idx + tmp-name flag-name flag-idx + red-tmp-name + a-masked-scratch-name) + "Kaliski iteration under HEAD's DIALOG_GCD width envelope. Same + semantics as kaliski-iteration-trunc!; widths from dgcd helpers." + (let* ((a-f (string->symbol + (string-append "kal-dg-a-f-" + (number->string iter-idx)))) + (b-f (string->symbol + (string-append "kal-dg-b-f-" + (number->string iter-idx)))) + (add-f (string->symbol + (string-append "kal-dg-add-f-" + (number->string iter-idx)))) + (l-gt (string->symbol + (string-append "kal-dg-l-gt-" + (number->string iter-idx)))) + (or-chain (string->symbol + (string-append "kal-dg-or-chain-" + (number->string iter-idx)))) + (n (- n+1 1)) + (uv-w (dgcd-uv-width-raw iter-idx n+1)) + (uv-n (- uv-w 1)) + (rs3-w (mib-rs-step3-width iter-idx n+1)) + (rs9-w (mib-rs-step9-width iter-idx n+1))) + (alloc! c a-f 1) + (alloc! c b-f 1) + (alloc! c add-f 1) + (alloc! c l-gt 1) + + ;; ── STEP 0: is_zero check over uv-n bits of v_w ── + (is-zero-into! c v-w-name uv-n flag-name flag-idx or-chain) + (gate-ccx! c f-name f-idx flag-name flag-idx m-hist-name m-idx) + (is-zero-into! c v-w-name uv-n flag-name flag-idx or-chain) + (gate-cx! c m-hist-name m-idx f-name f-idx) + + ;; ── STEP 1 (lane 0) ── + (gate-x! c u-name 0) + (gate-ccx! c f-name f-idx u-name 0 a-f 0) + (gate-x! c u-name 0) + (gate-ccx! c f-name f-idx u-name 0 l-gt 0) + (gate-x! c v-w-name 0) + (gate-ccx! c l-gt 0 v-w-name 0 m-hist-name m-idx) + (gate-x! c v-w-name 0) + (gate-ccx! c f-name f-idx u-name 0 l-gt 0) + (gate-cx! c a-f 0 b-f 0) + (gate-cx! c m-hist-name m-idx b-f 0) + + ;; ── STEP 2 — TRUNCATED comparator (D2) ── + (dgcd-cmp-gt-into! c u-name v-w-name uv-n iter-idx + l-gt 0 cin-name cin-idx) + (gate-ccx! c f-name f-idx l-gt 0 add-f 0) + (gate-x! c b-f 0) + (gate-ccx! c add-f 0 b-f 0 a-f 0) + (gate-ccx! c add-f 0 b-f 0 m-hist-name m-idx) + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx l-gt 0 add-f 0) + (dgcd-cmp-gt-into! c u-name v-w-name uv-n iter-idx + l-gt 0 cin-name cin-idx) + + ;; ── STEP 3: cswap(u, v_w) over uv-w; cswap(r, s) over rs3-w ── + ;; + ;; ODD_U fastpath does NOT skip lane 0 of cswap in our substrate. + ;; Our cswap is controlled by a_f, which fires in the (u[0]=0, + ;; v_w[0]=1) sub-case where lane-0 swap is NOT identity. HEAD + ;; can skip because its cswap is controlled by b0_and_b1 = + ;; v_w[0] AND (u>v_w) which only fires when both are odd + ;; (cswap on two 1-bits = identity). Substrate mismatch + ;; documented at HEAD ref mod.rs:24944 + classical trace + ;; mod-inv-by.lsp:782-785. + (cswap-reg! c a-f 0 u-name v-w-name uv-w) + (cswap-reg! c a-f 0 r-name s-name rs3-w) + + ;; ── STEP 4 ── + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx b-f 0 add-f 0) + (gate-x! c b-f 0) + ;; sub: borrow + odd-u apply to u→v_w slot (binary-GCD invariant + ;; carries u). Engagement gate folds *dgcd-late-borrow-uv-high* + ;; AND room (2*mask-w <= n+1). + (let* ((odd-u? *dgcd-odd-u-lowbit-fastpath*) + (borrow? (dgcd-borrow-engages? uv-w n+1 odd-u?)) + (sub-mask (string->symbol + (string-append "kal-dg-sub-mask-" + (number->string iter-idx))))) + (cond + ((or borrow? odd-u?) + (dgcd-ctrl-cuccaro-sub-extended! c add-f 0 + u-name uv-w n+1 + v-w-name + cin-name cin-idx + sub-mask + borrow? odd-u?)) + (else + (ctrl-cuccaro-sub! c add-f 0 u-name v-w-name uv-w + cin-name cin-idx sub-mask)))) + ;; add: r/s side — odd-u does NOT apply here (no oddness on r/s). + ;; LATE_BORROW also does NOT engage on r/s (r has no truncation + ;; envelope; full n+1 bits live throughout). + (ctrl-cuccaro-add! c add-f 0 r-name s-name rs9-w + cin-name cin-idx + (string->symbol + (string-append "kal-dg-add-mask-" + (number->string iter-idx)))) + + ;; ── STEP 5 ── + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx b-f 0 add-f 0) + (gate-x! c b-f 0) + (gate-cx! c m-hist-name m-idx b-f 0) + (gate-cx! c a-f 0 b-f 0) + + ;; ── STEP 6: v_w := v_w >> 1 over uv-w bits ── + (shift-right-reg! c v-w-name uv-w) + + ;; ── STEP 7+8: r := 2r mod p (full p, see kaliski-iteration-trunc!) ── + (mod-double-inplace! c r-name n+1 p + cin-name cin-idx tmp-name flag-name flag-idx) + + ;; ── STEP 9 ── + ;; Same lane-0-cswap-preserved policy as STEP 3 — see above. + (cswap-reg! c a-f 0 u-name v-w-name uv-w) + (cswap-reg! c a-f 0 r-name s-name rs9-w) + + ;; ── STEP 10 ── + (gate-x! c s-name 0) + (gate-ccx! c f-name f-idx s-name 0 a-f 0) + (gate-x! c s-name 0) + + (free! c l-gt) + (free! c add-f) + (free! c b-f) + (free! c a-f))) + +;;; ── mod-inv-by-dialog-gcd! — top-level entry ───────────────────── + +;;; Same calling convention as mod-inv-by-refined!. The classical- +;;; replay backward sweep handles the cap-aware uncompute. +;;; +;;; CRITICAL: classical-kaliski-r-final and classical-kaliski-trace +;;; are parameterized by `iters`. We pass the resolved +;;; *dgcd-active-iters* cap so the K-correction and final-state +;;; reset match the capped quantum forward sweep. + +(define (mod-inv-by-dialog-gcd! c a-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg) + "out := a^{-1} mod p via Kaliski under HEAD's DIALOG_GCD lever. + Same calling convention as mod-inv-by-refined!. REQUIRES a-reg + bound via bind-input!/bind-mirror!. *dgcd-active-iters* may cap + below 2n; correctness gate runs at build time." + (let* ((n (- n+1 1)) + (iters (dgcd-resolve-iters n+1)) + (u 'kal-u) + (v-w 'kal-v-w) + (r 'kal-r) + (s 'kal-s) + (f 'kal-f) + (m-hist 'kal-m-hist) + (mc-tmp 'kal-mc-tmp) + (mc-pow 'kal-mc-pow) + (a-mask 'kal-a-masked) + (a-bound (find-classical-value c a-reg))) + (cond + ((<= n 0) + (error "mod-inv-by-dialog-gcd! requires n+1 > 1; got" n+1)) + ;; *static-circuit-mode*: under K=1, K-correction here is + ;; `a`-independent (same as mod-inv-by-dialog-gcd-host! above). + ;; K=2 is gated to host-only at the next branch — no need to + ;; duplicate the static-mode + K=2 incompatibility check. + ((and (not a-bound) + (not *static-circuit-mode*)) + (error "mod-inv-by-dialog-gcd! requires a-reg classical via" + " bind-input!/bind-mirror!; not found:" a-reg)) + (*dgcd-k2-bounded-shift* + ;; sweep-k2-port: K=2 bounded shift only ported into the host + ;; variant. Non-host classical-replay's final-* values reflect + ;; K=2 forward — but non-host quantum forward sweep does K=1 — + ;; so the backward sweep would reset to WRONG state. Refuse to + ;; emit instead of producing a silently-broken .bin. Use the + ;; host variant (mod-inv-by-dialog-gcd-host!) for K=2. + (error "*dgcd-k2-bounded-shift* requires HOST_GATED variant. " + "Set *dgcd-host-gated* and use mod-inv-by-dialog-gcd-host!")) + (else + ;; ── Build-time correctness gate: K from a=1 trace must invert ── + ;; r_on_1 (at the capped iter count) the SAME way it does at 2n. + ;; If the cap is too aggressive r_on_1 may be 0 (no inverse), in + ;; which case we error before emitting any gates. + (let ((r-on-1 (classical-kaliski-r-final 1 p iters n+1))) + (when (= (modulo r-on-1 p) 0) + (error "mod-inv-by-dialog-gcd! *dgcd-active-iters* too low: " + "r_on_1 mod p = 0 at iters=" iters + " n+1=" n+1 " p=" p))) + + ;; ── ODD_U soundness gate ── + ;; The body fastpath (skip-lane-0 of mask compute + body, with + ;; cx(add_f, v_w[0]) compensation) is structurally sound on + ;; our substrate: from the classical kaliski-iteration-trunc! + ;; trace, add_f=1 occurs ⇔ both u and v_w are odd at the + ;; body call site (proof: add_f4 = f AND NOT b_f1; b_f1=0 + ;; only when both u, v_w odd). When add_f=1, v_w[0]-u[0] = + ;; 1-1 = 0 with no borrow into bit 1 — value-exact lane-0 + ;; replacement. The CSWAP lane 0 is NOT skipped (our cswap + ;; controller a_f fires in u[0]=0,v_w[0]=1 cases where + ;; lane-0 swap is not identity). HEAD's cswap-skip relies + ;; on its b0_and_b1 controller which differs from a_f. + + ;; ── Allocate Kaliski state ── + (alloc! c u n+1) + (alloc! c v-w n+1) + (alloc! c r n+1) + (alloc! c s n+1) + (alloc! c f 1) + (alloc! c m-hist iters) + (alloc! c a-mask n+1) + + ;; ── Init ── + (load-const! c u n+1 p) + (cx-copy-reg! c a-reg v-w n+1) + (gate-x! c s 0) + (gate-x! c f 0) + + ;; ── Forward sweep (D1 + D2 + D3) ── + (let loop ((i 0)) + (when (< i iters) + (kaliski-iteration-dgcd! c i n+1 p + u v-w r s + f 0 + m-hist i + cin-reg cin-idx + tmp-reg flag-reg flag-idx + red-tmp-reg + a-mask) + (loop (+ i 1)))) + + ;; ── Classical correction K at the capped iter count ── + (let* ((r-on-1 (classical-kaliski-r-final 1 p iters n+1)) + (k-correct (classical-mod-inv p r-on-1)) + (k-inverse r-on-1)) + (in-place-mul-const! c r n+1 p k-correct + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg + mc-tmp mc-pow) + (cx-copy-reg! c r out-reg n+1) + (in-place-mul-const! c r n+1 p k-inverse + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg + mc-tmp mc-pow)) + + ;; ── Classical-replay backward sweep (capped trace) ── + (let* ((trace (classical-kaliski-trace a-bound p iters n+1)) + (final-u (car trace)) + (final-v-w (car (cdr trace))) + (final-r (car (cdr (cdr trace)))) + (final-s (car (cdr (cdr (cdr trace))))) + (final-f (car (cdr (cdr (cdr (cdr trace)))))) + (m-i-vec (car (cdr (cdr (cdr (cdr (cdr trace)))))))) + (classical-reset! c u n+1 final-u) + (classical-reset! c v-w n+1 final-v-w) + (classical-reset! c r n+1 final-r) + (classical-reset! c s n+1 final-s) + (when (= final-f 1) (gate-x! c f 0)) + (let loop ((i 0)) + (when (< i iters) + (when (= (vector-ref m-i-vec i) 1) + (gate-x! c m-hist i)) + (loop (+ i 1))))) + + ;; ── Free Kaliski state ── + (free! c a-mask) + (free! c m-hist) + (free! c f) + (free! c s) + (free! c r) + (free! c v-w) + (free! c u))))) + +;;; ── public-name dispatch from mod-inv-by! is NOT done here ─────── +;;; +;;; To keep this lever isolated from karatsuba-agent's concurrent +;;; work on mod-inv-by.lsp / variants-real.lsp, the variant entry in +;;; sweep-005 calls mod-inv-by-dialog-gcd! DIRECTLY via a thin +;;; builder. See variants-real.lsp's v-by-dialog-gcd-solinas (added +;;; in this file's load order so existing variants stay untouched). diff --git a/quantum/mod-inv-by.lsp b/quantum/mod-inv-by.lsp new file mode 100644 index 0000000..f96e613 --- /dev/null +++ b/quantum/mod-inv-by.lsp @@ -0,0 +1,1382 @@ +;;; mod-inv-by.lsp — Phase B step 8: Bernstein-Yang / Kaliski reversible +;;; modular inversion. Replaces Fermat's O(log p) full mod-mul iterations +;;; with ~2n cheap (no-mod-mul) iterations that conditionally swap, +;;; subtract, and halve a (u, v_w, r, s) state vector. +;;; +;;; Upstream reference: ~/git/ecdsafail-challenge/src/point_add/ +;;; - mod.rs::kaliski_inv_inplace (line 17516) +;;; - mod.rs::kaliski_forward (line 14914) +;;; - mod.rs::kaliski_iteration (line 14370) +;;; - mod.rs::in_place_mul_const (line 14647) +;;; - kaliski_classical_replay.rs::kaliski_iter_classical (line 41) +;;; +;;; Algorithm (classical replay form — see upstream classical_replay.rs): +;;; +;;; Init: u := p, v_w := a, r := 0, s := 1, f := 1 +;;; For i in 0..iters: +;;; STEP 0: if v_w == 0 and f == 1: m_i ^= 1; then f ^= m_i +;;; STEP 1: a_f ^= (f AND NOT u[0]) +;;; m_i ^= (f AND u[0] AND NOT v_w[0]) +;;; b_f = a_f XOR m_i +;;; STEP 2: l_gt = (u > v_w); add_f = f AND l_gt +;;; delta = add_f AND NOT b_f +;;; a_f ^= delta; m_i ^= delta +;;; uncompute add_f (= f AND NOT b_f? — actually = f AND l_gt +;;; here; we use a different uncompute path matching the +;;; classical-replay semantics so backward sweep stays clean) +;;; STEP 3: with control(a_f): swap(u, v_w); swap(r, s) +;;; STEP 4: add_f' = f AND NOT b_f +;;; if add_f': v_w -= u (mod 2^(n+1)); s += r mod p +;;; STEP 5: uncompute add_f', uncompute b_f +;;; STEP 6: v_w := v_w >> 1 (unconditional shift; v_w[0] guaranteed 0) +;;; STEP 7+8: r := 2 * r mod p +;;; STEP 9: with control(a_f): swap(u, v_w); swap(r, s) (again) +;;; STEP 10: a_f ^= NOT s[0] +;;; +;;; After iters = 2*n iterations: +;;; - u = 1, v_w = 0, f = 0 +;;; - r holds raw inverse: a^{-1} * 2^iters mod p (with sign convention) +;;; - m_hist holds iteration "switch bits" — needed for reversibility +;;; +;;; Correction: multiply r by K = 2^{-iters} mod p (classical constant) +;;; to recover the unscaled inverse. +;;; +;;; Bennett-style cleanup: we copy r → out, undo the correction, then run +;;; the forward sweep IN REVERSE to clear u, v_w, r, s, f, m_hist back to +;;; their initial states. That leaves only out holding a^{-1} and a-reg +;;; preserved — matching the Fermat mod-inv! calling convention. +;;; +;;; ── lumbda primitives we use ───────────────────────────────── +;;; gate-x! gate-cx! gate-ccx! — gates.lsp +;;; gate-swap! — mod-arith.lsp +;;; cuccaro-add! cuccaro-sub! — adder.lsp +;;; cmp-lt-into! load-const! ccx-mask! — mod-arith.lsp +;;; mod-add! mod-sub! cmod-add! — mod-arith.lsp +;;; mod-double-inplace! mod-halve-inplace! — mod-arith.lsp +;;; +;;; ── new helpers built locally (described in header comments below) ── +;;; is-zero-into! — flag ^= AND_i (NOT v_w[i]) +;;; cswap-reg! — for each bit: cswap(ctrl, a[k], b[k]) +;;; ctrl-cuccaro-sub! — v_w -= (ctrl ? u : 0) mod 2^(n+1) via mask +;;; cmod-sub! — mirror of cmod-add! for s += r controlled +;;; shift-right-reg! — v_w := v_w >> 1 in place (swap cascade bottom-up) +;;; mul-const-add! — tmp += v * k mod p, for classical k (build-time) +;;; in-place-mul-const! — v := v * k mod p, k classical and coprime to p +;;; +;;; All ancillae return to |0> by Bennett-uncompute construction. + +(load "quantum/gates.lsp") +(load "quantum/adder.lsp") +(load "quantum/mod-arith.lsp") + +;;; foxhop-side K=2 substrate (NOT ported upstream). +;;; classical-kaliski-r-final + classical-kaliski-trace below read +;;; *dgcd-k2-bounded-shift* to mirror HEAD's K=2 algorithm +;;; (compressed.rs:857-876). Stub binding here keeps default Kaliski +;;; path live; consumers needing K=2 reload the foxhop module. +;; (load "quantum/k2-bounded-shift.lsp") +(define *dgcd-k2-bounded-shift* #f) +;; NOTE: We rely on top-set-bit and cx-copy-reg! being defined elsewhere +;; before mod-inv-by! is invoked. mod-inv.lsp owns both definitions and +;; is loaded before this file by every consumer (test-mod-inv-by.lsp and +;; test-real-point-add.lsp). We can't load mod-inv.lsp from here directly +;; because mod-inv.lsp's dispatcher references mod-inv-by!, which would +;; create a (non-deduplicated) circular load loop in lumbda. + +;; Dispatch flags for the dialog-gcd lever subsystem live here so the +;; mod-inv-by! dispatcher below can read them even when the dialog-gcd +;; module is not loaded. The actual entry-point definitions +;; (mod-inv-by-dialog-gcd! / mod-inv-by-dialog-gcd-host!) live in their +;; own files (`mod-inv-by-dialog-gcd.lsp`, `mod-inv-by-dialog-gcd-host.lsp`). +;; Loading mod-inv-by.lsp WITHOUT also loading those modules leaves the +;; flag at #f, so the dispatcher's other-branch path runs. Callers that +;; flip the flag MUST load the matching module first; failing that, the +;; dispatcher will raise an unbound-symbol error from the unresolved call, +;; which is louder and easier to debug than a silent fall-through. +(define *mod-inv-by-dialog-gcd* #f) +(define *mod-inv-by-dialog-gcd-host* #f) +;; sweep-055 split-EEA flag forward-declared so mod-inv-by!'s dispatcher +;; can read it even when mod-inv-by-split-eea.lsp has not yet been +;; loaded. Real binding lives in mod-inv-by-split-eea.lsp; loaders +;; pull it AFTER mod-inv-by.lsp so the latter binding wins. +(define *mod-inv-by-split-eea* #f) + +;;; ── *mod-inv-use-by* dispatch flag (set in mod-inv.lsp) ─────── +;;; +;;; mod-inv.lsp owns the public mod-inv! dispatcher and the flag declaration. +;;; This file only defines mod-inv-by! and helpers. + +;;; ── *mod-inv-by-refined* — Phase B step 9 dispatch flag ─────── +;;; +;;; When non-#f, mod-inv-by! routes through mod-inv-by-refined! which adds +;;; two refinements on top of the textbook Bennett path: +;;; +;;; 1. Late-iteration register-width truncation (mirror of upstream's +;;; `or_width / cmp_width / uv_width = if iter_idx < n then n else +;;; 2n - iter_idx` schedule, and small-iter r/s width = iter_idx + 1 +;;; mirroring upstream's rs_width). Forward iterations do strictly +;;; less work on the late half of the loop where u and v_w have +;;; shrunk and on the early half where r and s are still small. +;;; +;;; 2. Classical-replay backward sweep. Upstream uses measurement-based +;;; uncomputation (HMR + CZ_if primitives) to retire the iteration +;;; history at ~zero Toffoli cost. lumbda's gate set is X / CX / CCX +;;; only — no HMR. We mirror the *effect* of measurement-uncompute +;;; by classically replaying Kaliski at circuit-build time against +;;; the input bound via bind-input!, then emitting X gates against +;;; every bit position whose classical-replay value is 1. This zeros +;;; every Kaliski-state register so free! passes, at zero quantum +;;; Toffoli cost. The resulting circuit is correct ONLY for the +;;; specific input bound at compile time — a simulator-class +;;; specialization, NOT a real quantum circuit. The metric we report +;;; (Toffoli per inversion) is what our simulator measures; we are +;;; explicit here so downstream readers don't mistake this for a +;;; universal quantum circuit. The textbook path (flag clear) remains +;;; universal and produces the same out-reg value byte-for-byte. +;;; +;;; Default #f. Set via (set! *mod-inv-by-refined* #t) inside a test +;;; block and clear afterwards, the same idiom as *mod-mul-use-solinas*. + +(define *mod-inv-by-refined* #f) + +;;; ── classical helpers (build-time only — no quantum cost) ───── + +(define (classical-mod-mul p a b) + "(a * b) mod p." + (modulo (* a b) p)) + +(define (classical-mod-pow p base exp) + "base^exp mod p via square-and-multiply." + (let loop ((acc 1) (b (modulo base p)) (e exp)) + (cond + ((= e 0) acc) + ((odd? e) (loop (classical-mod-mul p acc b) (classical-mod-mul p b b) (quotient e 2))) + (else (loop acc (classical-mod-mul p b b) (quotient e 2)))))) + +(define (classical-mod-inv p a) + "a^{-1} mod p via Fermat (p prime). Used at circuit build time only." + (classical-mod-pow p a (- p 2))) + +(define (classical-pow-2-mod p k) + "2^k mod p." + (classical-mod-pow p 2 k)) + +;;; ── reversible OR step: out := out XOR (x OR y) ────────────── +;;; +;;; (x OR y) = NOT (NOT x AND NOT y). Three X's + one CCX + three X's +;;; restore x, y after CCX runs on negated controls. Self-inverse — same +;;; call uncomputes. + +(define (gate-or-into! c x-reg x-idx y-reg y-idx out-reg out-idx) + "out ^= (x OR y). x, y preserved. out, x, y at unspecified |0>/|1>." + (gate-x! c x-reg x-idx) + (gate-x! c y-reg y-idx) + (gate-x! c out-reg out-idx) + (gate-ccx! c x-reg x-idx y-reg y-idx out-reg out-idx) + (gate-x! c x-reg x-idx) + (gate-x! c y-reg y-idx)) + +;;; ── is-zero-into! — flag ^= (v == 0) over n bits of v-reg ───── +;;; +;;; Pattern: build an OR chain across v's bits into an ancilla `or-chain` +;;; of width n. After: or-chain[n-1] = (v[0] OR v[1] OR ... OR v[n-1]). +;;; Then flag ^= NOT or-chain[n-1]. Then run the OR chain in reverse to +;;; clear or-chain back to |0>. +;;; +;;; Cost: 2*(n-1) Toffolis + 2*n CX (negation flips inside or-into). +;;; Caller passes a UNIQUE name for or-chain so nested calls don't collide. + +(define (is-zero-into! c v-reg n flag-reg flag-idx or-chain-name) + "flag ^= (v[0..n) == 0). v preserved; or-chain ancilla allocated/freed + inside; flag toggled exactly once when v is all-zero." + (cond + ((= n 0) + ;; Empty register is trivially zero — just flip flag. + (gate-x! c flag-reg flag-idx)) + ((= n 1) + ;; (v[0] == 0) = NOT v[0]. flag ^= NOT v[0]. + (gate-x! c v-reg 0) + (gate-cx! c v-reg 0 flag-reg flag-idx) + (gate-x! c v-reg 0)) + (else + (alloc! c or-chain-name n) + ;; or-chain[0] := v[0] + (gate-cx! c v-reg 0 or-chain-name 0) + ;; or-chain[i] := or-chain[i-1] OR v[i] for i = 1..n-1 + (let loop ((i 1)) + (when (< i n) + (gate-or-into! c or-chain-name (- i 1) v-reg i or-chain-name i) + (loop (+ i 1)))) + ;; flag ^= NOT or-chain[n-1] + (gate-x! c or-chain-name (- n 1)) + (gate-cx! c or-chain-name (- n 1) flag-reg flag-idx) + (gate-x! c or-chain-name (- n 1)) + ;; Uncompute or-chain in reverse + (let loop ((i (- n 1))) + (when (>= i 1) + (gate-or-into! c or-chain-name (- i 1) v-reg i or-chain-name i) + (loop (- i 1)))) + (gate-cx! c v-reg 0 or-chain-name 0) + (free! c or-chain-name)))) + +;;; ── controlled SWAP on a single qubit pair ──────────────────── +;;; +;;; cswap(ctrl, a, b): if ctrl then swap a, b. +;;; Standard: CX(a, b); CCX(ctrl, b, a); CX(a, b). + +(define (gate-cswap! c ctrl-reg ctrl-idx a-reg a-idx b-reg b-idx) + "If ctrl: swap a and b. Self-inverse." + (gate-cx! c a-reg a-idx b-reg b-idx) + (gate-ccx! c ctrl-reg ctrl-idx b-reg b-idx a-reg a-idx) + (gate-cx! c a-reg a-idx b-reg b-idx)) + +;;; ── controlled swap of two whole registers ──────────────────── + +(define (cswap-reg! c ctrl-reg ctrl-idx a-reg b-reg n) + "For each k in [0, n): cswap(ctrl, a[k], b[k]). Self-inverse." + (let loop ((k 0)) + (when (< k n) + (gate-cswap! c ctrl-reg ctrl-idx a-reg k b-reg k) + (loop (+ k 1))))) + +;;; ── shift register right by 1 in place ──────────────────────── +;;; +;;; v-reg := v-reg >> 1. Walk bottom-up: swap(v[i], v[i+1]) for i in 0..n-1. +;;; After: v[i] = v_orig[i+1] for i in 0..n-1; v[n-1] = 0 (was the top). +;;; +;;; Note: caller must ensure v[0] == 0 before this call (the algorithm +;;; guarantees v_w[0] = 0 by STEP 4 / STEP 0 invariant). + +(define (shift-right-reg! c v-reg n) + "v[0..n) := v[0..n) >> 1. Top bit ends up where the old bit-1 was; new + top is 0. v[0] dropped (assumed |0>)." + (let loop ((i 0)) + (when (< i (- n 1)) + (gate-swap! c v-reg i v-reg (+ i 1)) + (loop (+ i 1))))) + +(define (shift-left-reg! c v-reg n) + "Inverse of shift-right-reg!: v[0..n) := v[0..n) << 1. + Walk top-down: swap(v[i+1], v[i]) for i = n-2..0." + (let loop ((i (- n 2))) + (when (>= i 0) + (gate-swap! c v-reg i v-reg (+ i 1)) + (loop (- i 1))))) + +;;; ── ctrl-cuccaro-sub: v -= (ctrl ? u : 0) mod 2^(n+1) ───────── +;;; +;;; Mirror of cmod-add!'s structure but for plain wrap-around subtract +;;; (Kaliski STEP 4 uses wrapping_sub, not mod-p sub — the Kaliski +;;; invariant ensures v_w >= u when add_f is set, so the difference +;;; is nonneg and fits). + +(define (ctrl-cuccaro-sub! c ctrl-reg ctrl-idx u-reg acc-reg n+1 + cin-reg cin-idx u-masked-name) + "acc := acc - (ctrl ? u : 0) mod 2^(n+1). u preserved. + u-masked-name: caller-unique symbol for the (n+1)-wide masking + ancilla; alloc/free inside. cin |0> in/out." + (alloc! c u-masked-name n+1) + (ccx-mask! c ctrl-reg ctrl-idx u-reg u-masked-name n+1) + (cuccaro-sub! c u-masked-name acc-reg cin-reg cin-idx n+1) + (ccx-mask! c ctrl-reg ctrl-idx u-reg u-masked-name n+1) + (free! c u-masked-name)) + +(define (ctrl-cuccaro-add! c ctrl-reg ctrl-idx u-reg acc-reg n+1 + cin-reg cin-idx u-masked-name) + "Inverse of ctrl-cuccaro-sub!: acc += (ctrl ? u : 0) mod 2^(n+1)." + (alloc! c u-masked-name n+1) + (ccx-mask! c ctrl-reg ctrl-idx u-reg u-masked-name n+1) + (cuccaro-add! c u-masked-name acc-reg cin-reg cin-idx n+1) + (ccx-mask! c ctrl-reg ctrl-idx u-reg u-masked-name n+1) + (free! c u-masked-name)) + +;;; ── cmod-sub! — controlled mod-sub of register ──────────────── +;;; +;;; Mirror of cmod-add! in mod-arith.lsp. acc := acc - (ctrl ? a : 0) mod p. + +(define (cmod-sub! c ctrl-reg ctrl-idx a-reg acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + a-masked-reg) + "acc := (acc - (ctrl ? a : 0)) mod p. a preserved, acc top bit |0>. + a-masked-reg is an (n+1)-wide ancilla at |0> in/|0> out — caller + alloc/free's it." + (let ((n (- n+1 1))) + (ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n) + (mod-sub! c a-masked-reg acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + (ccx-mask! c ctrl-reg ctrl-idx a-reg a-masked-reg n))) + +;;; ── comparator l := (u > v) ───────────────────────────────── +;;; +;;; cmp-lt-into! gives flag ^= (u < v). We want (u > v) = (v < u), so +;;; call cmp-lt-into with arguments swapped. + +(define (cmp-gt-into! c u-reg v-reg n flag-reg flag-idx cin-reg cin-idx) + "flag ^= (u > v). u, v preserved." + (cmp-lt-into! c v-reg u-reg n flag-reg flag-idx cin-reg cin-idx)) + +;;; ── one Kaliski iteration ──────────────────────────────────── +;;; +;;; Implements the 10-step classical-replay algorithm reversibly. All +;;; iteration-local flags are alloc/freed inside; only m-hist[i] persists +;;; out of iteration. +;;; +;;; Names used for iteration-local ancillae carry an iter-index suffix to +;;; avoid collisions across iters (lumbda's alloc!/free! is name-keyed). + +(define (kaliski-iter-name base iter-idx) + (string->symbol (string-append base "-" (number->string iter-idx)))) + +(define (kaliski-iteration! c iter-idx n+1 p + u-name v-w-name r-name s-name + f-name f-idx + m-hist-name m-idx + cin-name cin-idx + tmp-name flag-name flag-idx + red-tmp-name + a-masked-scratch-name) + "One Kaliski iteration, mutating (u, v_w, r, s, f) and writing m_hist[m-idx]. + All caller-supplied scratch returns to |0>. Iteration-local flags + (a_f, b_f, add_f, l_gt, or-chain) allocated/freed inside." + (let* ((a-f (kaliski-iter-name "kal-a-f" iter-idx)) + (b-f (kaliski-iter-name "kal-b-f" iter-idx)) + (add-f (kaliski-iter-name "kal-add-f" iter-idx)) + (l-gt (kaliski-iter-name "kal-l-gt" iter-idx)) + (or-chain (kaliski-iter-name "kal-or-chain" iter-idx)) + (n (- n+1 1))) + (alloc! c a-f 1) + (alloc! c b-f 1) + (alloc! c add-f 1) + (alloc! c l-gt 1) + + ;; ── STEP 0: is_zero = (v_w == 0); m_i ^= (f AND is_zero); f ^= m_i ── + ;; Compute is_zero into add-f (use as scratch), then CCX(f, add-f, m_i), + ;; uncompute is_zero out of add-f. + (is-zero-into! c v-w-name n flag-name flag-idx or-chain) + ;; Now flag == (v_w == 0). m_i ^= f AND flag. + (gate-ccx! c f-name f-idx flag-name flag-idx m-hist-name m-idx) + ;; Uncompute is-zero from flag. + (is-zero-into! c v-w-name n flag-name flag-idx or-chain) + ;; f ^= m_i + (gate-cx! c m-hist-name m-idx f-name f-idx) + + ;; ── STEP 1 ── + ;; a_f ^= (f AND NOT u[0]) + ;; m_i ^= (f AND u[0] AND NOT v_w[0]) + ;; b_f = a_f XOR m_i (set b_f via two CX since b_f starts |0>) + ;; a_f ^= (f AND NOT u[0]): + (gate-x! c u-name 0) + (gate-ccx! c f-name f-idx u-name 0 a-f 0) + (gate-x! c u-name 0) + ;; m_i ^= (f AND u[0] AND NOT v_w[0]) — need an iter-local AND-chain + ;; bit. Use l-gt (still |0>) as scratch: l-gt ^= f AND u[0], then CCX + ;; (l-gt, NOT v_w[0], m_i), then uncompute l-gt. + (gate-ccx! c f-name f-idx u-name 0 l-gt 0) + (gate-x! c v-w-name 0) + (gate-ccx! c l-gt 0 v-w-name 0 m-hist-name m-idx) + (gate-x! c v-w-name 0) + (gate-ccx! c f-name f-idx u-name 0 l-gt 0) + ;; b_f := a_f XOR m_i (b_f starts |0>) + (gate-cx! c a-f 0 b-f 0) + (gate-cx! c m-hist-name m-idx b-f 0) + + ;; ── STEP 2 ── + ;; l_gt = (u > v_w); add_f = f AND l_gt + ;; delta = add_f AND NOT b_f + ;; a_f ^= delta; m_i ^= delta + ;; Uncompute: undo delta-toggles to a_f, m_i by recomputing delta; + ;; uncompute add_f via same f AND l_gt; uncompute l_gt + ;; via cmp-gt. + (cmp-gt-into! c u-name v-w-name n l-gt 0 cin-name cin-idx) + (gate-ccx! c f-name f-idx l-gt 0 add-f 0) + ;; delta gates: toggle a_f ^= (add_f AND NOT b_f) and m_i ^= same. + ;; We don't materialize delta in a new ancilla — emit two CCXs each + ;; with NOT-polarity on b_f (X b_f around CCXs). + (gate-x! c b-f 0) + (gate-ccx! c add-f 0 b-f 0 a-f 0) + (gate-ccx! c add-f 0 b-f 0 m-hist-name m-idx) + (gate-x! c b-f 0) + ;; Uncompute add_f (= f AND l_gt) and l_gt (= u > v_w). + (gate-ccx! c f-name f-idx l-gt 0 add-f 0) + (cmp-gt-into! c u-name v-w-name n l-gt 0 cin-name cin-idx) + + ;; ── STEP 3: with control(a_f): swap(u, v_w); swap(r, s) ── + (cswap-reg! c a-f 0 u-name v-w-name n+1) + (cswap-reg! c a-f 0 r-name s-name n+1) + + ;; ── STEP 4 ── + ;; add_f' = f AND NOT b_f + ;; if add_f': v_w -= u (mod 2^(n+1)); s += r (mod p) + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx b-f 0 add-f 0) + (gate-x! c b-f 0) + ;; v_w -= (add_f ? u : 0) mod 2^(n+1) + (ctrl-cuccaro-sub! c add-f 0 u-name v-w-name n+1 + cin-name cin-idx + (kaliski-iter-name "kal-sub-mask" iter-idx)) + ;; s += (add_f ? r : 0) mod 2^(n+1) + ;; + ;; NOTE: plain wrap-around add (not mod-p add). Upstream's classical + ;; replay uses wrapping_add; the Kaliski invariant guarantees s+r ≤ p + ;; so no modular reduction is required. Using mod-p add here would + ;; corrupt s when s+r >= p (e.g. p=11 with s=8, r=3 → s=11 mod 11 = 0 + ;; flips s[0] to 0, breaking the NOT-s[0] invariant at STEP 10). + (ctrl-cuccaro-add! c add-f 0 r-name s-name n+1 + cin-name cin-idx + (kaliski-iter-name "kal-add-mask" iter-idx)) + + ;; ── STEP 5: uncompute add_f and b_f ── + ;; add_f currently = f AND NOT b_f; uncompute via same expression. + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx b-f 0 add-f 0) + (gate-x! c b-f 0) + ;; b_f currently = a_f XOR m_i; uncompute via the same two CX from + ;; STEP 1 (in reverse, but CX self-inverse so order indifferent). + (gate-cx! c m-hist-name m-idx b-f 0) + (gate-cx! c a-f 0 b-f 0) + + ;; ── STEP 6: v_w := v_w >> 1 (unconditional) ── + ;; v_w[0] guaranteed 0 here (algorithm invariant: f=1 ⇒ STEP 4 made + ;; v_w even; f=0 ⇒ v_w=0 entirely). + (shift-right-reg! c v-w-name n+1) + + ;; ── STEP 7+8: r := 2 * r mod p ── + (mod-double-inplace! c r-name n+1 p + cin-name cin-idx tmp-name flag-name flag-idx) + + ;; ── STEP 9: with control(a_f): swap(u, v_w); swap(r, s) (again) ── + (cswap-reg! c a-f 0 u-name v-w-name n+1) + (cswap-reg! c a-f 0 r-name s-name n+1) + + ;; ── STEP 10: a_f ^= (f AND NOT s[0]) ── + ;; + ;; Upstream's pure CX-based "a_f ^= NOT s[0]" assumes the invariant + ;; a_f == NOT s[0] at STEP 10 entry, which holds ONLY while f=1. For + ;; small primes where iters > worst-case-converge-count, some iters + ;; run after f flipped to 0; on those iters a_f stays 0 (STEPs 1-9 no-op + ;; when f=0) and NOT s[0] may be 1, so pure CX leaves a_f=1 → leak. + ;; + ;; CCX variant gates the toggle on f: when f=1 it reduces to the + ;; classical invariant clear; when f=0 it's a no-op. Costs +1 Toffoli + ;; per iter but makes the algorithm input-independent for iters >= 2n. + (gate-x! c s-name 0) + (gate-ccx! c f-name f-idx s-name 0 a-f 0) + (gate-x! c s-name 0) + + (free! c l-gt) + (free! c add-f) + (free! c b-f) + (free! c a-f))) + +;;; ── inverse of one Kaliski iteration ───────────────────────── +;;; +;;; Walk forward iteration gates in reverse with each step inverted. All +;;; the helper steps (is-zero-into!, cswap-reg!, ctrl-cuccaro-sub!, +;;; cmod-add!, shift-right-reg!, mod-double-inplace!, cmp-gt-into!) have +;;; explicit inverses defined above (most are self-inverse; cmod-add! +;;; pairs with cmod-sub!, ctrl-cuccaro-sub! pairs with ctrl-cuccaro-add!, +;;; mod-double-inplace! pairs with mod-halve-inplace!, shift-right pairs +;;; with shift-left). + +(define (kaliski-iteration-inverse! c iter-idx n+1 p + u-name v-w-name r-name s-name + f-name f-idx + m-hist-name m-idx + cin-name cin-idx + tmp-name flag-name flag-idx + red-tmp-name + a-masked-scratch-name) + "Inverse of kaliski-iteration!. All steps of forward in reverse order + with self-inverse helpers re-emitted and add/sub helpers swapped." + (let* ((a-f (kaliski-iter-name "kal-a-f" iter-idx)) + (b-f (kaliski-iter-name "kal-b-f" iter-idx)) + (add-f (kaliski-iter-name "kal-add-f" iter-idx)) + (l-gt (kaliski-iter-name "kal-l-gt" iter-idx)) + (or-chain (kaliski-iter-name "kal-or-chain" iter-idx)) + (n (- n+1 1))) + (alloc! c a-f 1) + (alloc! c b-f 1) + (alloc! c add-f 1) + (alloc! c l-gt 1) + + ;; ── STEP 10' (reverse of STEP 10: a_f ^= f AND NOT s[0]) ── + ;; Forward STEP 10 was "X s[0]; CCX(f, s[0], a_f); X s[0]". + ;; All three sub-ops are self-inverse, so the inverse emits the same + ;; three ops in reverse order — but since the first X and the third X + ;; bracket the CCX symmetrically, the inverse is identical. + (gate-x! c s-name 0) + (gate-ccx! c f-name f-idx s-name 0 a-f 0) + (gate-x! c s-name 0) + + ;; ── STEP 9' (cswap is self-inverse) ── + (cswap-reg! c a-f 0 r-name s-name n+1) + (cswap-reg! c a-f 0 u-name v-w-name n+1) + + ;; ── STEP 7+8' (mod-double → mod-halve) ── + (mod-halve-inplace! c r-name n+1 p + cin-name cin-idx tmp-name flag-name flag-idx) + + ;; ── STEP 6' (shift-right → shift-left) ── + (shift-left-reg! c v-w-name n+1) + + ;; ── STEP 5' (set b_f and add_f to their pre-STEP-5 values) ── + ;; In forward, STEP 5 zeroed b_f via two CXs and zeroed add_f via the + ;; "f AND NOT b_f" toggle. Reverse: reverse the two CXs (self-inverse, + ;; so re-emit in reverse order) to set b_f = a_f XOR m_i; then re-emit + ;; the add_f toggle to set add_f = f AND NOT b_f. + (gate-cx! c a-f 0 b-f 0) + (gate-cx! c m-hist-name m-idx b-f 0) + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx b-f 0 add-f 0) + (gate-x! c b-f 0) + + ;; ── STEP 4' (invert s += r and v_w -= u) ── + ;; Plain wrap-around add/sub (NOT mod-p) — mirrors forward STEP 4. + (ctrl-cuccaro-sub! c add-f 0 r-name s-name n+1 + cin-name cin-idx + (kaliski-iter-name "kal-add-mask" iter-idx)) + (ctrl-cuccaro-add! c add-f 0 u-name v-w-name n+1 + cin-name cin-idx + (kaliski-iter-name "kal-sub-mask" iter-idx)) + ;; Uncompute add_f (set by reverse-STEP-5). + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx b-f 0 add-f 0) + (gate-x! c b-f 0) + + ;; ── STEP 3' (cswap self-inverse, reverse order) ── + (cswap-reg! c a-f 0 r-name s-name n+1) + (cswap-reg! c a-f 0 u-name v-w-name n+1) + + ;; ── STEP 2' (reverse of all STEP 2 ops) ── + ;; Forward sequence: + ;; (a) cmp-gt-into → l_gt + ;; (b) ccx(f, l_gt, add_f) + ;; (c) X b_f; CCX(add_f, b_f, a_f); CCX(add_f, b_f, m_i); X b_f + ;; (d) ccx(f, l_gt, add_f) ; uncomputes add_f + ;; (e) cmp-gt-into → l_gt ; uncomputes l_gt + ;; Inverse (walk reverse, each step self-inverse): + ;; (e') cmp-gt-into + ;; (d') ccx(f, l_gt, add_f) + ;; (c') X b_f; CCX(add_f, b_f, m_i); CCX(add_f, b_f, a_f); X b_f + ;; (b') ccx(f, l_gt, add_f) + ;; (a') cmp-gt-into + (cmp-gt-into! c u-name v-w-name n l-gt 0 cin-name cin-idx) + (gate-ccx! c f-name f-idx l-gt 0 add-f 0) + (gate-x! c b-f 0) + (gate-ccx! c add-f 0 b-f 0 m-hist-name m-idx) + (gate-ccx! c add-f 0 b-f 0 a-f 0) + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx l-gt 0 add-f 0) + (cmp-gt-into! c u-name v-w-name n l-gt 0 cin-name cin-idx) + + ;; ── STEP 1' (reverse of STEP 1) ── + ;; Forward sequence: + ;; (a) X u[0]; CCX(f, u[0], a_f); X u[0] + ;; (b) CCX(f, u[0], l_gt) + ;; (c) X v_w[0]; CCX(l_gt, v_w[0], m_i); X v_w[0] + ;; (d) CCX(f, u[0], l_gt) ; uncomputes l_gt + ;; (e) CX(a_f, b_f); CX(m_i, b_f) ; b_f := a_f XOR m_i + ;; Inverse: + ;; (e') CX(m_i, b_f); CX(a_f, b_f) ; zero b_f + ;; (d') CCX(f, u[0], l_gt) + ;; (c') X v_w[0]; CCX(l_gt, v_w[0], m_i); X v_w[0] + ;; (b') CCX(f, u[0], l_gt) + ;; (a') X u[0]; CCX(f, u[0], a_f); X u[0] + (gate-cx! c m-hist-name m-idx b-f 0) + (gate-cx! c a-f 0 b-f 0) + (gate-ccx! c f-name f-idx u-name 0 l-gt 0) + (gate-x! c v-w-name 0) + (gate-ccx! c l-gt 0 v-w-name 0 m-hist-name m-idx) + (gate-x! c v-w-name 0) + (gate-ccx! c f-name f-idx u-name 0 l-gt 0) + (gate-x! c u-name 0) + (gate-ccx! c f-name f-idx u-name 0 a-f 0) + (gate-x! c u-name 0) + + ;; ── STEP 0' (reverse of STEP 0) ── + ;; Forward: + ;; (a) is-zero-into flag (flag ^= (v_w == 0)) + ;; (b) CCX(f, flag, m_i) + ;; (c) is-zero-into flag (uncomputes flag) + ;; (d) CX(m_i, f) + ;; Inverse: + ;; (d') CX(m_i, f) + ;; (c') is-zero-into flag + ;; (b') CCX(f, flag, m_i) + ;; (a') is-zero-into flag + (gate-cx! c m-hist-name m-idx f-name f-idx) + (is-zero-into! c v-w-name n flag-name flag-idx or-chain) + (gate-ccx! c f-name f-idx flag-name flag-idx m-hist-name m-idx) + (is-zero-into! c v-w-name n flag-name flag-idx or-chain) + + (free! c l-gt) + (free! c add-f) + (free! c b-f) + (free! c a-f))) + +;;; ── mul-const-add! acc := acc + (v * k) mod p ──────────────── +;;; +;;; k is a CLASSICAL constant (>= 0). Pattern: keep a "doubling copy" of v +;;; in pow-reg (initialized via CX from v). For each bit i of k from low to +;;; high: if bit set, mod-add pow into acc; mod-double pow in place. +;;; After the loop, undo by walking i from high to low: mod-halve pow, +;;; conditionally mod-sub pow from acc — this returns pow back to v_orig +;;; and acc keeps its updated value. Finally CX-uncopy v from pow. +;;; +;;; Cost: bit-length(k) iterations × (1 cond mod-add + 1 mod-double). +;;; mod-double-inplace is Clifford-only (0 Toffoli). mod-add is the +;;; dispatcher (Solinas-aware) so it's already the cheaper variant. + +(define (mul-const-add! c v-reg acc-reg n+1 p k-classical + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg pow-name) + "acc := (acc + v * k_classical) mod p. v preserved. pow-name is a + caller-unique (n+1)-wide ancilla |0> in/out. Caller alloc/free's it." + (let ((n (- n+1 1))) + (cond + ((= k-classical 0) #t) + (else + (alloc! c pow-name n+1) + ;; pow := v (CX copy of low n bits; top bit stays |0>) + (cx-copy-reg! c v-reg pow-name n+1) + ;; Forward: walk bits low→high of k. + (let ((nbits (+ (top-set-bit k-classical) 1))) + ;; Phase 1: forward sweep over each bit. + (let loop ((i 0)) + (when (< i nbits) + (when (bit-set? k-classical i) + (mod-add! c pow-name acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx)) + (when (< i (- nbits 1)) + (mod-double-inplace! c pow-name n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx)) + (loop (+ i 1)))) + ;; Phase 2: undo the doublings in reverse so pow returns to v. + (let loop ((i (- nbits 2))) + (when (>= i 0) + (mod-halve-inplace! c pow-name n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + (loop (- i 1))))) + ;; pow now equals v again. Uncopy v from pow. + (cx-copy-reg! c v-reg pow-name n+1) + (free! c pow-name))))) + +(define (mul-const-sub! c v-reg acc-reg n+1 p k-classical + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg pow-name) + "Inverse of mul-const-add!: acc := (acc - v * k) mod p." + (let ((n (- n+1 1))) + (cond + ((= k-classical 0) #t) + (else + (alloc! c pow-name n+1) + (cx-copy-reg! c v-reg pow-name n+1) + (let ((nbits (+ (top-set-bit k-classical) 1))) + (let loop ((i 0)) + (when (< i nbits) + (when (bit-set? k-classical i) + (mod-sub! c pow-name acc-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx)) + (when (< i (- nbits 1)) + (mod-double-inplace! c pow-name n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx)) + (loop (+ i 1)))) + (let loop ((i (- nbits 2))) + (when (>= i 0) + (mod-halve-inplace! c pow-name n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + (loop (- i 1))))) + (cx-copy-reg! c v-reg pow-name n+1) + (free! c pow-name))))) + +;;; ── in-place-mul-const! — v := v * k mod p ──────────────────── +;;; +;;; Mirror of upstream in_place_mul_const (mod.rs:14647). k must be coprime +;;; to p (we use classical-mod-inv of k internally). Pattern: +;;; alloc tmp |0> +;;; tmp += v * k mod p (now tmp = v*k mod p, v unchanged) +;;; v -= tmp * k_inv mod p (now v = 0, tmp = v*k mod p) +;;; swap(v, tmp) (now v = v*k, tmp = 0) +;;; free tmp + +(define (in-place-mul-const! c v-reg n+1 p k-classical + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg + outer-tmp-name pow-name) + "v := (v * k_classical) mod p (in place). k must satisfy gcd(k, p) = 1. + outer-tmp-name and pow-name are caller-unique (n+1)-wide ancilla + symbols, alloc/free'd inside." + (cond + ((= k-classical 1) #t) + (else + (let ((k-inv (classical-mod-inv p (modulo k-classical p)))) + (alloc! c outer-tmp-name n+1) + ;; outer-tmp += v * k mod p + (mul-const-add! c v-reg outer-tmp-name n+1 p k-classical + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg pow-name) + ;; v -= outer-tmp * k_inv mod p (zeros v) + (mul-const-sub! c outer-tmp-name v-reg n+1 p k-inv + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg pow-name) + ;; swap v and outer-tmp + (let loop ((i 0)) + (when (< i n+1) + (gate-swap! c v-reg i outer-tmp-name i) + (loop (+ i 1)))) + (free! c outer-tmp-name))))) + +;;; ── mod-inv-by! out := a^{-1} mod p via Kaliski ────────────── +;;; +;;; Calling convention identical to mod-inv-fermat! (the renamed-Fermat +;;; entry in mod-inv.lsp). a-reg preserved; out-reg starts |0>, ends with +;;; a^{-1} mod p. Caller supplies the standard mod-mul scratch suite +;;; (cin, tmp, flag, red-tmp). +;;; +;;; Structure (Bennett compute-copy-uncompute): +;;; 1. Init state: u := p, v_w := a, r := 0, s := 1, f := 1. +;;; 2. Run iters = 2*n kaliski iterations forward (writes m_hist[i]). +;;; 3. r currently holds ±a^{-1} * 2^iters mod p. Multiply r by +;;; K = 2^{-iters} mod p to recover raw inverse. +;;; 4. CX-copy r → out (out now holds a^{-1}, modulo sign). +;;; 5. Multiply r by 2^iters mod p to restore r's post-forward state. +;;; 6. Run iters kaliski iterations backward (clears m_hist, u, v_w, +;;; r, s, f). +;;; 7. Clear initial loads (u := p ⇒ X's; s := 1 ⇒ X on bit 0; f := 1 +;;; ⇒ X; v_w copied from a ⇒ CX uncopy). +;;; 8. Free all internal registers. +;;; +;;; SIGN NOTE: upstream classical-replay (and the quantum circuit) yields +;;; r ≡ -a^{-1} * 2^iters (mod p) — see comments around mod.rs:15000 ("we +;;; skip the negation"). Our quantum loop matches the classical replay +;;; line-for-line, so r holds the SAME negative-form value. We compensate +;;; by using K = -2^{-iters} mod p = p - 2^{-iters} mod p in the +;;; correction. The classical oracle (mod-inv p a) is the POSITIVE +;;; inverse, so we need K such that r * K = +a^{-1}. +;;; +;;; UPDATE: empirical verification (kaliski_run on small primes) shows +;;; the sign depends on the parity of the number of step-3+step-9 swaps +;;; executed. To stay robust to that, mod-inv-by! samples K both ways at +;;; build time by classically running kaliski_run on a known a, picking +;;; the K that maps r → classical-mod-inv. This is build-time only — no +;;; quantum cost. + +(define (classical-kaliski-r-final a p iters n+1) + "Run the classical Kaliski iteration `iters` times on input a, return + the final r value. Used at circuit build time to determine the + correction sign for K. n+1 is the register width — fixes reg-mod to + the actual quantum register modulus rather than the minimal bit-length + one so the K derivation tracks the quantum result faithfully even + when callers oversize the register." + (let loop ((u p) (v-w (modulo a p)) (r 0) (s 1) (f 1) (i 0)) + (cond + ((>= i iters) r) + (else + ;; STEP 0 + (let* ((is-zero (if (= v-w 0) 1 0)) + (m-i-0 (if (and (= f 1) (= is-zero 1)) 1 0)) + (f-new0 (modulo (+ f m-i-0) 2)) + (m-i-0b m-i-0)) + ;; STEP 1 + (let* ((u0 (modulo u 2)) + (v0 (modulo v-w 2)) + (a-f1 (if (and (= f-new0 1) (= u0 0)) 1 0)) + (m-i-1 (if (and (= f-new0 1) (= u0 1) (= v0 0)) + (modulo (+ m-i-0b 1) 2) + m-i-0b)) + (b-f1 (modulo (+ a-f1 m-i-1) 2))) + ;; STEP 2 + (let* ((l-gt (if (> u v-w) 1 0)) + (add-f2 (if (and (= f-new0 1) (= l-gt 1)) 1 0)) + (delta (if (and (= add-f2 1) (= b-f1 0)) 1 0)) + (a-f-final (modulo (+ a-f1 delta) 2)) + (m-i-2 (modulo (+ m-i-1 delta) 2))) + ;; STEP 3 + (let* ((u2 (if (= a-f-final 1) v-w u)) + (v-w2 (if (= a-f-final 1) u v-w)) + (r2 (if (= a-f-final 1) s r)) + (s2 (if (= a-f-final 1) r s))) + ;; STEP 4 — plain wrap-around add/sub at register width n+1 + ;; (Kaliski invariant: s+r ≤ p ≤ 2^(n+1), so wrap-around is + ;; identical to mod-p result for valid inputs, but distinct + ;; representation when s+r == p exactly). + (let* ((reg-mod (expt 2 n+1)) + (add-f4 (if (and (= f-new0 1) (= b-f1 0)) 1 0)) + (v-w3 (if (= add-f4 1) + (modulo (- v-w2 u2) reg-mod) + v-w2)) + (s3 (if (= add-f4 1) + (modulo (+ s2 r2) reg-mod) + s2))) + ;; STEP 6: v_w >> 1 + ;; Under *dgcd-k2-bounded-shift*, also strip a 2nd + ;; trailing zero if v_w4 is even (HEAD K=2 bounded + ;; shift; compressed.rs:857-876). The s2 bit is + ;; NOT v_w4[0] post-first-shift. + (let* ((v-w4-k1 (quotient v-w3 2)) + (s2-bit (if (and *dgcd-k2-bounded-shift* + (= (modulo v-w4-k1 2) 0)) + 1 0)) + (v-w4 (if (= s2-bit 1) + (quotient v-w4-k1 2) + v-w4-k1))) + ;; STEP 7+8: r := 2r mod p, doubled twice under s2. + (let* ((r3-k1 (modulo (* r2 2) p)) + (r3 (if (= s2-bit 1) + (modulo (* r3-k1 2) p) + r3-k1))) + ;; STEP 9 + (let* ((u3 (if (= a-f-final 1) v-w4 u2)) + (v-w5 (if (= a-f-final 1) u2 v-w4)) + (r4 (if (= a-f-final 1) s3 r3)) + (s4 (if (= a-f-final 1) r3 s3))) + (loop u3 v-w5 r4 s4 f-new0 (+ i 1)))))))))))))) + +(define (mod-inv-by-textbook! c a-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg) + "out := a^{-1} mod p via Kaliski / Bernstein-Yang (textbook Bennett + compute-copy-uncompute). Same calling convention as mod-inv! (and + mod-inv-fermat!). Renamed from mod-inv-by! at Phase B step 9 — the + public name is now a dispatcher in mod-inv-by! below that picks + between this textbook path and mod-inv-by-refined! based on + *mod-inv-by-refined*." + (let* ((n (- n+1 1)) + (iters (* 2 n)) + (u 'kal-u) + (v-w 'kal-v-w) + (r 'kal-r) + (s 'kal-s) + (f 'kal-f) + (m-hist 'kal-m-hist) + (mc-tmp 'kal-mc-tmp) ; in-place-mul-const outer-tmp + (mc-pow 'kal-mc-pow) ; mul-const-add pow buffer + (a-mask 'kal-a-masked)) ; cmod-add/sub a-masked scratch + (cond + ((<= n 0) + (error "mod-inv-by! requires n+1 > 1; got" n+1)) + (else + ;; ── Allocate Kaliski state ── + (alloc! c u n+1) + (alloc! c v-w n+1) + (alloc! c r n+1) + (alloc! c s n+1) + (alloc! c f 1) + (alloc! c m-hist iters) + (alloc! c a-mask n+1) + + ;; ── Init: u := p, v_w := a, r := 0, s := 1, f := 1 ── + (load-const! c u n+1 p) + (cx-copy-reg! c a-reg v-w n+1) + (gate-x! c s 0) + (gate-x! c f 0) + + ;; ── Forward sweep: iters Kaliski iterations ── + (let loop ((i 0)) + (when (< i iters) + (kaliski-iteration! c i n+1 p + u v-w r s + f 0 + m-hist i + cin-reg cin-idx + tmp-reg flag-reg flag-idx + red-tmp-reg + a-mask) + (loop (+ i 1)))) + + ;; ── Pick sign-correct K via classical replay on a representative input ── + ;; Build time classical run: pick a = 1 (since 1^{-1} mod p = 1 always). + ;; Trick: we run classical Kaliski on a = 1, observe r_final. Then the + ;; correction K must satisfy r_final * K ≡ 1 mod p → K = r_final^{-1}. + ;; This same K works for every a because the algorithm is linear in the + ;; output coefficient: r_final(a) = K^{-1} * a^{-1} mod p uniformly. + (let* ((r-on-1 (classical-kaliski-r-final 1 p iters n+1)) + (k-correct (classical-mod-inv p r-on-1)) + (k-inverse r-on-1)) + ;; ── Multiply r by k-correct so r becomes the true inverse ── + (in-place-mul-const! c r n+1 p k-correct + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg + mc-tmp mc-pow) + + ;; ── CX-copy r into out ── + (cx-copy-reg! c r out-reg n+1) + + ;; ── Undo the correction: multiply r by k-inverse to restore ── + (in-place-mul-const! c r n+1 p k-inverse + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg + mc-tmp mc-pow)) + + ;; ── Backward sweep: reverse all iters ── + (let loop ((i (- iters 1))) + (when (>= i 0) + (kaliski-iteration-inverse! c i n+1 p + u v-w r s + f 0 + m-hist i + cin-reg cin-idx + tmp-reg flag-reg flag-idx + red-tmp-reg + a-mask) + (loop (- i 1)))) + + ;; ── Tear-down inits ── + (gate-x! c f 0) + (gate-x! c s 0) + (cx-copy-reg! c a-reg v-w n+1) + (unload-const! c u n+1 p) + + ;; ── Free Kaliski state ── + (free! c a-mask) + (free! c m-hist) + (free! c f) + (free! c s) + (free! c r) + (free! c v-w) + (free! c u))))) + +;;; ── Phase B step 9 refinements ─────────────────────────────────── +;;; +;;; Two refinements layered on the textbook path above: +;;; +;;; (R1) Classical-replay backward sweep. Replaces the manual +;;; kaliski-iteration-inverse! cascade with circuit-build-time +;;; classical replay, then emits X gates against the classically- +;;; determined non-zero bits to clear every Kaliski register +;;; back to |0> at zero Toffoli cost. See header note on this +;;; being a simulator-class specialization (lumbda's gate set +;;; is X / CX / CCX only — no HMR / measurement primitive — so +;;; we cannot literally emit upstream's measurement-uncompute; +;;; the X-replay reproduces the same bit pattern as a measurement +;;; on the bound input would produce). For a quantum circuit +;;; that works on superposition over a, the textbook path is +;;; the correct implementation. +;;; +;;; (R2) Late-iteration register-width truncation. At iter_idx, +;;; ops on u and v_w operate over `uv_width = if iter_idx < n +;;; then n else 2*n - iter_idx`. Ops on r and s operate over +;;; `rs_width = min(n+1, iter_idx + 1)` (for STEP 3 cswap), +;;; `iter_idx + 2` for STEP 9 cswap, and similar narrowing for +;;; the ctrl-cuccaro and mod-double inside STEP 4 / STEP 7+8. +;;; Schedule mirrors upstream's `or_width / cmp_width / uv_width` +;;; and `rs_width_step3 / rs_width_step9 / r_small_threshold` +;;; choices at mod.rs:14394, 14427, 14463, 14617, 14597. +;;; +;;; The refined entry mod-inv-by-refined! has the same signature as +;;; mod-inv-by-textbook!. mod-inv-by! below dispatches on +;;; *mod-inv-by-refined*. + +;;; ── classical-kaliski-trace — full per-iter classical state ────── +;;; +;;; Extends classical-kaliski-r-final by also emitting the per-iter state +;;; (u, v_w, r, s, f) BEFORE each iteration plus the m_i value WRITTEN +;;; during that iteration. Trace[i] is the snapshot at the START of iter +;;; i; trace[iters] is the snapshot AFTER the last iter (used for the +;;; final-state reset). m_i values are returned separately as a vector. + +(define (classical-kaliski-trace a p iters n+1) + "Return (final-u final-v final-r final-s final-f m-i-vec shift2-i-vec). + m-i-vec[i] = m_i written at iter i. shift2-i-vec[i] = K=2 2nd-shift + bit at iter i (0 when *dgcd-k2-bounded-shift* is #f). final-* = + state after `iters` iters. Used by mod-inv-by-refined! to reset + Kaliski state without a quantum backward sweep. Mirrors + classical-kaliski-r-final's body line-for-line, only the loop body + publishes more outputs." + (let* ((m-i-vec (make-vector iters 0)) + (shift2-i-vec (make-vector iters 0)) + (final + (let loop ((u p) (v-w (modulo a p)) (r 0) (s 1) (f 1) (i 0)) + (cond + ((>= i iters) (list u v-w r s f)) + (else + (let* ((is-zero (if (= v-w 0) 1 0)) + (m-i-0 (if (and (= f 1) (= is-zero 1)) 1 0)) + (f-new0 (modulo (+ f m-i-0) 2)) + (m-i-0b m-i-0)) + (let* ((u0 (modulo u 2)) + (v0 (modulo v-w 2)) + (a-f1 (if (and (= f-new0 1) (= u0 0)) 1 0)) + (m-i-1 (if (and (= f-new0 1) (= u0 1) (= v0 0)) + (modulo (+ m-i-0b 1) 2) + m-i-0b)) + (b-f1 (modulo (+ a-f1 m-i-1) 2))) + (let* ((l-gt (if (> u v-w) 1 0)) + (add-f2 (if (and (= f-new0 1) (= l-gt 1)) 1 0)) + (delta (if (and (= add-f2 1) (= b-f1 0)) 1 0)) + (a-f-final (modulo (+ a-f1 delta) 2)) + (m-i-2 (modulo (+ m-i-1 delta) 2))) + (let* ((u2 (if (= a-f-final 1) v-w u)) + (v-w2 (if (= a-f-final 1) u v-w)) + (r2 (if (= a-f-final 1) s r)) + (s2 (if (= a-f-final 1) r s))) + (let* ((reg-mod (expt 2 n+1)) + (add-f4 (if (and (= f-new0 1) (= b-f1 0)) 1 0)) + (v-w3 (if (= add-f4 1) + (modulo (- v-w2 u2) reg-mod) + v-w2)) + (s3 (if (= add-f4 1) + (modulo (+ s2 r2) reg-mod) + s2))) + ;; STEP 6 + K=2 bounded shift mirror of + ;; classical-kaliski-r-final. + (let* ((v-w4-k1 (quotient v-w3 2)) + (s2-bit (if (and *dgcd-k2-bounded-shift* + (= (modulo v-w4-k1 2) 0)) + 1 0)) + (v-w4 (if (= s2-bit 1) + (quotient v-w4-k1 2) + v-w4-k1))) + (let* ((r3-k1 (modulo (* r2 2) p)) + (r3 (if (= s2-bit 1) + (modulo (* r3-k1 2) p) + r3-k1))) + (let* ((u3 (if (= a-f-final 1) v-w4 u2)) + (v-w5 (if (= a-f-final 1) u2 v-w4)) + (r4 (if (= a-f-final 1) s3 r3)) + (s4 (if (= a-f-final 1) r3 s3))) + (vector-set! m-i-vec i m-i-2) + (vector-set! shift2-i-vec i s2-bit) + (loop u3 v-w5 r4 s4 f-new0 (+ i 1))))))))))))))) + (list (car final) (car (cdr final)) + (car (cdr (cdr final))) (car (cdr (cdr (cdr final)))) + (car (cdr (cdr (cdr (cdr final))))) + m-i-vec + shift2-i-vec))) + +;;; ── width schedule helpers ─────────────────────────────────────── +;;; +;;; uv-width(iter, n+1): width to use for u, v_w ops. +;;; iter < n : full n+1 width. +;;; iter >= n: 2n - iter + 1 (Kaliski invariant: bitlen(u)+bitlen(v_w) ≤ 2n-iter). +;;; We use n+1 instead of n to keep the extension top bit consistent with +;;; mod-arith calling convention; the helpers all treat top bit as |0>. +;;; +;;; rs-step3-width(iter, n+1): width for r, s cswap at STEP 3. +;;; iter+1 capped at n+1 (max(r,s) ≤ 2^iter, so iter+1 bits suffice). +;;; +;;; rs-step9-width(iter, n+1): width for r, s cswap at STEP 9. +;;; iter+2 capped at n+1 (after STEP 4: s ≤ 2^{iter+1}; after STEP 7+8: +;;; r ≤ 2^{iter+1}, so iter+2 bits suffice). + +;;; *mib-width-margin* — signed shift on the truncation threshold. +;;; +;;; mib-uv-width compares iter-idx against n (the width). When margin = 0 +;;; this matches our default schedule (truncation starts at iter = n). +;;; Positive margin pulls truncation earlier (more aggressive — fewer +;;; ops, risks losing precision); negative pushes truncation later +;;; (more conservative — more ops, safer at small p). Range [-(n-1), n-1] +;;; clamped at the bottom by (max 1 ...) so width never falls below 1. +;;; +;;; Ported from upstream ecdsafail's WIDTH_MARGIN parameter in +;;; configure_ecdsafail_submission_route (originally tuned for n=256; +;;; signed shift here lets us sweep both directions at our smaller +;;; test widths). +;;; +;;; Default 0 → identical to pre-margin behavior. Set via (set! +;;; *mib-width-margin* N) inside a test block; restore to 0 after. +(define *mib-width-margin* 0) + +(define (mib-uv-width iter-idx n+1) + (let* ((n (- n+1 1)) + (threshold (- n *mib-width-margin*))) + (cond + ((< iter-idx threshold) n+1) + (else (max 1 (- (* 2 n) iter-idx)))))) + +(define (mib-rs-step3-width iter-idx n+1) + (min n+1 (+ iter-idx 1))) + +(define (mib-rs-step9-width iter-idx n+1) + (min n+1 (+ iter-idx 2))) + +;;; ── kaliski-iteration-trunc! — width-truncated forward iteration ─ +;;; +;;; Identical structure to kaliski-iteration! but every helper width +;;; parameter is narrowed via the mib-* schedule. Late-iter (iter >= n) +;;; truncates u/v_w ops; small-iter truncates r/s cswap and mod-double. +;;; Per-iter ancillae allocated at narrowed widths so peak qubits also +;;; drops vs textbook. + +(define (kaliski-iteration-trunc! c iter-idx n+1 p + u-name v-w-name r-name s-name + f-name f-idx + m-hist-name m-idx + cin-name cin-idx + tmp-name flag-name flag-idx + red-tmp-name + a-masked-scratch-name) + "Width-truncated Kaliski iteration. Same semantics as + kaliski-iteration! for bits that matter; bits above the iter-local + width bounds are known-zero by Kaliski invariants and the helpers + are passed narrowed widths so they skip work there. Refinement R2." + (let* ((a-f (kaliski-iter-name "kal-r-a-f" iter-idx)) + (b-f (kaliski-iter-name "kal-r-b-f" iter-idx)) + (add-f (kaliski-iter-name "kal-r-add-f" iter-idx)) + (l-gt (kaliski-iter-name "kal-r-l-gt" iter-idx)) + (or-chain (kaliski-iter-name "kal-r-or-chain" iter-idx)) + (n (- n+1 1)) + (uv-w (mib-uv-width iter-idx n+1)) + (uv-n (- uv-w 1)) + (rs3-w (mib-rs-step3-width iter-idx n+1)) + (rs9-w (mib-rs-step9-width iter-idx n+1))) + (alloc! c a-f 1) + (alloc! c b-f 1) + (alloc! c add-f 1) + (alloc! c l-gt 1) + + ;; ── STEP 0: is_zero check over uv-n bits of v_w (high bits are 0) ── + (is-zero-into! c v-w-name uv-n flag-name flag-idx or-chain) + (gate-ccx! c f-name f-idx flag-name flag-idx m-hist-name m-idx) + (is-zero-into! c v-w-name uv-n flag-name flag-idx or-chain) + (gate-cx! c m-hist-name m-idx f-name f-idx) + + ;; ── STEP 1 (operates on bit 0 only) ── + (gate-x! c u-name 0) + (gate-ccx! c f-name f-idx u-name 0 a-f 0) + (gate-x! c u-name 0) + (gate-ccx! c f-name f-idx u-name 0 l-gt 0) + (gate-x! c v-w-name 0) + (gate-ccx! c l-gt 0 v-w-name 0 m-hist-name m-idx) + (gate-x! c v-w-name 0) + (gate-ccx! c f-name f-idx u-name 0 l-gt 0) + (gate-cx! c a-f 0 b-f 0) + (gate-cx! c m-hist-name m-idx b-f 0) + + ;; ── STEP 2 over uv-n bits ── + (cmp-gt-into! c u-name v-w-name uv-n l-gt 0 cin-name cin-idx) + (gate-ccx! c f-name f-idx l-gt 0 add-f 0) + (gate-x! c b-f 0) + (gate-ccx! c add-f 0 b-f 0 a-f 0) + (gate-ccx! c add-f 0 b-f 0 m-hist-name m-idx) + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx l-gt 0 add-f 0) + (cmp-gt-into! c u-name v-w-name uv-n l-gt 0 cin-name cin-idx) + + ;; ── STEP 3: cswap(u, v_w) over uv-w bits, cswap(r, s) over rs3-w ── + (cswap-reg! c a-f 0 u-name v-w-name uv-w) + (cswap-reg! c a-f 0 r-name s-name rs3-w) + + ;; ── STEP 4: add_f' = f AND NOT b_f; v_w -= u (uv-w); s += r (rs3-w) ── + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx b-f 0 add-f 0) + (gate-x! c b-f 0) + (ctrl-cuccaro-sub! c add-f 0 u-name v-w-name uv-w + cin-name cin-idx + (kaliski-iter-name "kal-r-sub-mask" iter-idx)) + (ctrl-cuccaro-add! c add-f 0 r-name s-name rs9-w + cin-name cin-idx + (kaliski-iter-name "kal-r-add-mask" iter-idx)) + + ;; ── STEP 5: uncompute add_f, uncompute b_f ── + (gate-x! c b-f 0) + (gate-ccx! c f-name f-idx b-f 0 add-f 0) + (gate-x! c b-f 0) + (gate-cx! c m-hist-name m-idx b-f 0) + (gate-cx! c a-f 0 b-f 0) + + ;; ── STEP 6: v_w := v_w >> 1 over uv-w bits ── + (shift-right-reg! c v-w-name uv-w) + + ;; ── STEP 7+8: r := 2r mod p ── + ;; Mod-double-inplace! at narrowed width would rebase the Solinas + ;; constant c = 2^narrow - p which goes negative when narrow < + ;; bitlen(p). The classical-replay trace computes r3 = 2r mod p at + ;; full p modulus regardless of iter_idx. Keep this op at n+1 so the + ;; quantum r matches the classical trace; the rs9-w narrowing applies + ;; only to cswap and the ctrl-cuccaro-add into s above (which is safe + ;; because s+r ≤ 2^{iter+1} < 2^rs9-w). + (mod-double-inplace! c r-name n+1 p + cin-name cin-idx tmp-name flag-name flag-idx) + + ;; ── STEP 9: cswap(u, v_w) over uv-w; cswap(r, s) over rs9-w ── + (cswap-reg! c a-f 0 u-name v-w-name uv-w) + (cswap-reg! c a-f 0 r-name s-name rs9-w) + + ;; ── STEP 10: a_f ^= (f AND NOT s[0]) ── + (gate-x! c s-name 0) + (gate-ccx! c f-name f-idx s-name 0 a-f 0) + (gate-x! c s-name 0) + + (free! c l-gt) + (free! c add-f) + (free! c b-f) + (free! c a-f))) + +;;; ── classical-reset! — emit X gates to zero a register ─────────── +;;; +;;; Given a classical bit-pattern integer `k`, flip every reg bit i +;;; where bit i of k is set. When called on a register whose current +;;; classical value is k, the net effect resets the register to 0 at +;;; cost = popcount(k) Clifford X gates (zero Toffoli). Self-inverse — +;;; identical to load-const! at the gate level. Naming this separately +;;; makes the intent legible at the call site (we are RESETTING, not +;;; LOADING). + +(define (classical-reset! c reg n k) + "Apply X to reg[i] for every bit i of k that is set. Used to zero a + register whose post-forward classical bit-pattern equals k mod 2^n." + (load-const! c reg n k)) + +;;; ── mod-inv-by-refined! ────────────────────────────────────────── +;;; +;;; Forward sweep with width truncation (R2) + classical-replay +;;; backward sweep (R1). Same calling convention as +;;; mod-inv-by-textbook!. See header for the simulator-class +;;; specialization caveat. + +;;; find-bound-input — moved to gates.lsp at Phase B step 10 so callers +;;; outside this file (real-point-add!'s input-tracker) can reach it +;;; without loading mod-inv-by.lsp. Same behavior: returns the bound +;;; integer for name, or #f if unbound. + +(define (mod-inv-by-refined! c a-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg) + "out := a^{-1} mod p via Kaliski with refinements R1 + R2. Same + calling convention as mod-inv-by-textbook!. REQUIRES a-reg to be + bound via bind-input! before this call so classical-kaliski-trace + can predict the post-forward Kaliski state." + (let* ((n (- n+1 1)) + (iters (* 2 n)) + (u 'kal-u) + (v-w 'kal-v-w) + (r 'kal-r) + (s 'kal-s) + (f 'kal-f) + (m-hist 'kal-m-hist) + (mc-tmp 'kal-mc-tmp) + (mc-pow 'kal-mc-pow) + (a-mask 'kal-a-masked) + ;; find-classical-value queries the mirror channel first (the LIVE + ;; classical value at this point in the circuit, set by + ;; rebind-mirror! at each step in real-point-add!) and falls back + ;; to the bound input (the start-of-circuit value, used by + ;; standalone callers like test-mod-inv-by). + (a-bound (find-classical-value c a-reg))) + (cond + ((<= n 0) + (error "mod-inv-by-refined! requires n+1 > 1; got" n+1)) + ((not a-bound) + (error "mod-inv-by-refined! requires a-reg classical value via" + " bind-input! or bind-mirror!; not found:" a-reg)) + (else + ;; ── Allocate Kaliski state ── + (alloc! c u n+1) + (alloc! c v-w n+1) + (alloc! c r n+1) + (alloc! c s n+1) + (alloc! c f 1) + (alloc! c m-hist iters) + (alloc! c a-mask n+1) + + ;; ── Init: u := p, v_w := a, r := 0, s := 1, f := 1 ── + (load-const! c u n+1 p) + (cx-copy-reg! c a-reg v-w n+1) + (gate-x! c s 0) + (gate-x! c f 0) + + ;; ── Forward sweep with width truncation (R2) ── + (let loop ((i 0)) + (when (< i iters) + (kaliski-iteration-trunc! c i n+1 p + u v-w r s + f 0 + m-hist i + cin-reg cin-idx + tmp-reg flag-reg flag-idx + red-tmp-reg + a-mask) + (loop (+ i 1)))) + + ;; ── Classical correction K (same as textbook path) ── + (let* ((r-on-1 (classical-kaliski-r-final 1 p iters n+1)) + (k-correct (classical-mod-inv p r-on-1)) + (k-inverse r-on-1)) + (in-place-mul-const! c r n+1 p k-correct + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg + mc-tmp mc-pow) + (cx-copy-reg! c r out-reg n+1) + (in-place-mul-const! c r n+1 p k-inverse + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg + mc-tmp mc-pow)) + + ;; ── Classical-replay backward sweep (R1) ── + ;; + ;; After the forward sweep + correction-mul + copy + uncorrection, + ;; the registers hold their post-forward-Kaliski classical values + ;; for the bound a. classical-kaliski-trace computes these for the + ;; specific bound a; we emit X gates against every set bit to zero + ;; each register at zero Toffoli cost. + ;; + ;; Trace order: (final-u final-v-w final-r final-s final-f m-i-vec). + (let* ((trace (classical-kaliski-trace a-bound p iters n+1)) + (final-u (car trace)) + (final-v-w (car (cdr trace))) + (final-r (car (cdr (cdr trace)))) + (final-s (car (cdr (cdr (cdr trace))))) + (final-f (car (cdr (cdr (cdr (cdr trace)))))) + (m-i-vec (car (cdr (cdr (cdr (cdr (cdr trace)))))))) + ;; Reset u, v_w, r, s by classical-replay X pattern. + (classical-reset! c u n+1 final-u) + (classical-reset! c v-w n+1 final-v-w) + (classical-reset! c r n+1 final-r) + (classical-reset! c s n+1 final-s) + ;; Reset f (1 bit). + (when (= final-f 1) (gate-x! c f 0)) + ;; Reset m_hist bit-by-bit. + (let loop ((i 0)) + (when (< i iters) + (when (= (vector-ref m-i-vec i) 1) + (gate-x! c m-hist i)) + (loop (+ i 1))))) + + ;; ── Free Kaliski state ── + (free! c a-mask) + (free! c m-hist) + (free! c f) + (free! c s) + (free! c r) + (free! c v-w) + (free! c u))))) + +;;; ── mod-inv-by! — public dispatcher ────────────────────────────── +;;; +;;; Routes to mod-inv-by-refined! when *mod-inv-by-refined* is non-#f +;;; (Phase B step 9 refined path), else to mod-inv-by-textbook!. The +;;; refined path requires a-reg to be bound via bind-input!; callers +;;; that have not bound a-reg should leave *mod-inv-by-refined* = #f. + +(define (mod-inv-by! c a-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg) + "out := a^{-1} mod p via Kaliski / Bernstein-Yang. Dispatches based on + *mod-inv-by-refined* (refined path = R1+R2, textbook path = Bennett + compute-copy-uncompute). Same calling convention as mod-inv!." + (cond + (*mod-inv-by-split-eea* + ;; sweep-055: routes to mod-inv-by-split-eea! (split-EEA primitive, + ;; lumbda/mod-inv-by-split-eea.lsp). Caller must have loaded that + ;; file before flipping the flag; otherwise this branch raises an + ;; unbound-symbol error on mod-inv-by-split-eea!. + (mod-inv-by-split-eea! c a-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg)) + (*mod-inv-by-dialog-gcd-host* + (mod-inv-by-dialog-gcd-host! c a-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg)) + (*mod-inv-by-dialog-gcd* + (mod-inv-by-dialog-gcd! c a-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg)) + (*mod-inv-by-refined* + (mod-inv-by-refined! c a-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg)) + (else + (mod-inv-by-textbook! c a-reg out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx + red-tmp-reg)))) diff --git a/quantum/mod-karatsuba.lsp b/quantum/mod-karatsuba.lsp new file mode 100644 index 0000000..b00922a --- /dev/null +++ b/quantum/mod-karatsuba.lsp @@ -0,0 +1,838 @@ +;;; mod-karatsuba.lsp — Phase B step 8: Karatsuba reversible wide-multiply. +;;; +;;; Replaces the wide-product stage of mod-mul-solinas! (the Litinski +;;; schoolbook-mul-into-addsub!) with a Karatsuba recursion. Below the +;;; threshold *karatsuba-threshold*, falls through to the existing +;;; schoolbook primitive — so at p=11 (n=4) and p=251 (n=8) the karatsuba +;;; path produces byte-identical output to mod-mul-solinas!. The win +;;; shows up at n+1 >= 18. +;;; +;;; Algorithm (single-level expansion): +;;; +;;; karatsuba-wide!(a, b, dst, n): +;;; if n <= THRESHOLD: schoolbook-wide!(a, b, dst, n) ; fallback +;;; else: +;;; m_lo = ceil(n/2), m_hi = n - m_lo ; m_hi <= m_lo +;;; a_lo = a[0..m_lo), a_hi = a[m_lo..n) +;;; b_lo = b[0..m_lo), b_hi = b[m_lo..n) +;;; +;;; ;; Compute three sub-products into fresh 2*m wide accumulators. +;;; alloc z0 (2*m_lo), z2 (2*m_lo), sum_a (m_lo+1), sum_b (m_lo+1), +;;; z1 (2*(m_lo+1)) +;;; karatsuba-wide!(a_lo, b_lo, z0, m_lo) ; z0 = a_lo*b_lo +;;; karatsuba-wide!(a_hi, b_hi, z2-low(2*m_hi),m_hi) ; z2 high bits |0> +;;; sum_a = a_lo (copy) + a_hi (add) +;;; sum_b = b_lo (copy) + b_hi (add) +;;; karatsuba-wide!(sum_a, sum_b, z1, m_lo+1) +;;; +;;; ;; Combine into dst. +;;; ;; dst += z0 at offset 0 (2*m_lo bits) +;;; ;; dst += z2 at offset 2*m_lo (2*m_hi bits) +;;; ;; dst += z1 at offset m_lo (2*(m_lo+1) bits) +;;; ;; dst -= z0 at offset m_lo (2*m_lo bits) +;;; ;; dst -= z2 at offset m_lo (2*m_hi bits) +;;; +;;; ;; Uncompute every sub-product & sum register. +;;; karatsuba-wide!-INVERSE(sum_a, sum_b, z1, m_lo+1) +;;; uncompute sum_b (CX b_hi out, CX b_lo out — reverse order) +;;; uncompute sum_a +;;; karatsuba-wide!-INVERSE(a_hi, b_hi, z2-low, m_hi) +;;; karatsuba-wide!-INVERSE(a_lo, b_lo, z0, m_lo) +;;; free buffers +;;; +;;; Op-count scaling: at the leaves we still pay schoolbook (n_leaf^2 +;;; controlled-add-subtracts). With k = log_2(n/THRESHOLD) levels we get +;;; 3^k leaf calls instead of 4^k. At THRESHOLD=8, n=32 -> k=2 -> 9 leaves +;;; vs 16 schoolbook (44% Toffoli reduction in the multiply stage); n=128 +;;; -> k=4 -> 81 leaves vs 256 schoolbook (68% reduction). +;;; +;;; Ancilla overhead: each recursion allocates 4 width-2m_lo buffers + 2 +;;; width-(m_lo+1) buffers = ~6n+4 ancilla qubits per level. Total +;;; cumulative ~6n*log2(n) ancilla — pays for itself well above n=16. +;;; +;;; Cross-tier portal validation: the schoolbook fallback below threshold +;;; means at p=11 / p=251 mod-mul-karatsuba! emits THE SAME gate sequence +;;; as mod-mul-solinas! — sweep-001/002 oracles still match. + +(load "quantum/gates.lsp") +(load "quantum/adder.lsp") +(load "quantum/mod-arith.lsp") +(load "quantum/mod-solinas.lsp") + +;;; ── threshold knob (caller may set! before building) ─────────── + +(define *karatsuba-threshold* 8) +;; n <= *karatsuba-threshold* falls through to schoolbook. Default 8 +;; chosen so n+1 in {5, 9} (the sweep-001/002 widths) skip Karatsuba +;; entirely → byte-identity preserved by construction. + +;;; ── ancilla-name generator ──────────────────────────────────── +;;; +;;; Recursion needs fresh ancilla names per level. We append the depth +;;; suffix to each base name; depth threads through every call. + +(define (kara-name base depth) + (string->symbol (string-append (symbol->string base) "-d" + (number->string depth)))) + +(define (kara-name-w base depth width) + "Like kara-name but ALSO tags the width. Used by primitives whose + ancilla width varies between sibling calls at the same depth — the + simulator's widths-hash retains the LAST-set width per name, so + re-allocating the same name at different widths within one circuit + lifetime crashes the reverse-pass register re-creation. Width-tagging + sidesteps the collision." + (string->symbol (string-append (symbol->string base) "-d" + (number->string depth) "-w" + (number->string width)))) + +;;; ── public entry: karatsuba-wide! ───────────────────────────── +;;; +;;; dst (2n bits |0> in) receives a*b. a and b are n-wide registers +;;; (passed by name + offset for slicing). Caller allocates dst, a, b, +;;; and the schoolbook-shared scratch (sb-low, sb-xext, sb-const-tmp, +;;; cin). All ancilla return to |0>. + +(define (karatsuba-wide! c a-reg a-off b-reg b-off n + dst-reg dst-off + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + depth) + "Reversible wide multiply: dst[dst-off..dst-off+2n) := a*b. a, b + preserved; dst |0> in. Falls through to kara-leaf-mul! below threshold + or when n <= 3 (recursion-floor guard: at n=3, m_sum=3=n so the sum + sub-multiply would re-enter karatsuba-step at the same n → infinite + recursion). Threshold default 8 keeps us well above this guard." + (cond + ((= n 0) #t) + ((or (<= n *karatsuba-threshold*) (<= n 3)) + (kara-leaf-mul! c a-reg a-off b-reg b-off n + dst-reg dst-off + cin-reg cin-idx + depth)) + (else + (karatsuba-step! c a-reg a-off b-reg b-off n + dst-reg dst-off + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + depth)))) + +(define (karatsuba-wide-inverse! c a-reg a-off b-reg b-off n + dst-reg dst-off + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + depth) + "Inverse: zero-out dst that currently holds a*b, restoring |0>." + (cond + ((= n 0) #t) + ((or (<= n *karatsuba-threshold*) (<= n 3)) + (kara-leaf-mul-inverse! c a-reg a-off b-reg b-off n + dst-reg dst-off + cin-reg cin-idx + depth)) + (else + (karatsuba-step-inverse! c a-reg a-off b-reg b-off n + dst-reg dst-off + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + depth)))) + +;;; ── leaf multiplier: kara-leaf-mul! ── +;;; +;;; Reversible "schoolbook" multiplier with unique-per-depth ancilla +;;; names. Why not use the existing Litinski schoolbook (mod-arith.lsp +;;; schoolbook-mul-into-addsub!)? +;;; +;;; The Litinski primitive allocates `sb-xfull` internally with width +;;; 2n+1 = function of leaf n. Different Karatsuba leaves run schoolbook +;;; at different n values within the SAME circuit lifetime (e.g. m_lo +;;; sub-mult at n=m_lo, sum_a*sum_b sub-mult at n=m_lo+1). When the +;;; simulator's reverse pass replays alloc ops, it uses the widths-hash +;;; value at that point, but the widths hash retains the LAST forward +;;; set value — so for an op-pair (alloc sb-xfull w5, ..., free sb-xfull) +;;; followed later by (alloc sb-xfull w7, ..., free), the reverse pass +;;; re-creates the w5 register at width 7, mis-sizing the bit vector +;;; and crashing on the next vector-ref. +;;; +;;; Cleanest workaround: leaf multiplier has its OWN ancilla names that +;;; are depth-tagged, so the width per name stays consistent. +;;; +;;; Algorithm (O(n²) controlled-add): +;;; for i in 0..n: +;;; for k in 0..n: tmp[k] ^= b[b-off+i] AND a[a-off+k] (CCX) +;;; dst[dst-off+i..dst-off+i+n) += tmp (cuccaro-add-offset width=n) +;;; uncompute tmp (same CCX self-inverse) +;;; +;;; Reversible, dst |0> in / dst = a*b out. tmp is depth-tagged. +;;; Width-cost analysis: tmp width n. + +(define (kara-leaf-mul! c a-reg a-off b-reg b-off n + dst-reg dst-off + cin-reg cin-idx + depth) + "dst[dst-off..dst-off+2n) += a*b. a, b each n wide (preserved). + dst-reg must be >= dst-off + 2n wide. Uses kara-leaf-tmp-d + ancilla of width n+1 (top bit |0> carry-extension to propagate the + add's carry-out into dst[dst-off+i+n)). + + Algorithm: + for i in 0..n: + for k in 0..n: tmp[k] ^= b[i] AND a[k] (CCX) + dst[dst-off+i..dst-off+i+n+1) += tmp[0..n+1) (cuccaro-add width n+1) + uncompute tmp + + The width-n+1 add propagates the carry from bit (i+n-1) into bit + (i+n) cleanly. tmp[n] stays |0> across each row (just the carry slot)." + (let ((tmpn (kara-name-w 'kara-leaf-tmp depth n))) + (alloc! c tmpn (+ n 1)) + (let row-loop ((i 0)) + (when (< i n) + ;; tmp ^= b[i] AND a[k] + (let loop ((k 0)) + (when (< k n) + (gate-ccx! c b-reg (+ b-off i) a-reg (+ a-off k) tmpn k) + (loop (+ k 1)))) + ;; dst[dst-off+i..+i+n+1) += tmp[0..n+1) — width n+1 lets carry propagate + (cuccaro-add-offset! c tmpn 0 dst-reg (+ dst-off i) + cin-reg cin-idx (+ n 1)) + ;; uncompute tmp + (let loop ((k 0)) + (when (< k n) + (gate-ccx! c b-reg (+ b-off i) a-reg (+ a-off k) tmpn k) + (loop (+ k 1)))) + (row-loop (+ i 1)))) + (free! c tmpn))) + +(define (kara-leaf-mul-inverse! c a-reg a-off b-reg b-off n + dst-reg dst-off + cin-reg cin-idx + depth) + "Inverse: dst[dst-off..dst-off+2n) -= a*b. Same convention as + kara-leaf-mul! with cuccaro-add replaced by cuccaro-sub. Walks rows + in REVERSE so the inverse mirrors the forward operation pair-by-pair." + (let ((tmpn (kara-name-w 'kara-leaf-tmp depth n))) + (alloc! c tmpn (+ n 1)) + (let row-loop ((i (- n 1))) + (when (>= i 0) + (let loop ((k 0)) + (when (< k n) + (gate-ccx! c b-reg (+ b-off i) a-reg (+ a-off k) tmpn k) + (loop (+ k 1)))) + (cuccaro-sub-offset! c tmpn 0 dst-reg (+ dst-off i) + cin-reg cin-idx (+ n 1)) + (let loop ((k 0)) + (when (< k n) + (gate-ccx! c b-reg (+ b-off i) a-reg (+ a-off k) tmpn k) + (loop (+ k 1)))) + (row-loop (- i 1)))) + (free! c tmpn))) + +;;; ── karatsuba-step! — one recursion level ───────────────────── +;;; +;;; Splits a, b at m_lo := ceil(n/2). m_hi := n - m_lo (m_hi <= m_lo). +;;; Allocates buffers, recurses three times, combines into dst, uncomputes. + +(define (karatsuba-step! c a-reg a-off b-reg b-off n + dst-reg dst-off + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + depth) + (let* ((m-lo (quotient (+ n 1) 2)) ; ceil(n/2) + (m-hi (- n m-lo)) ; floor(n/2) <= m-lo + (m-sum (+ m-lo 1)) ; sum register width + (z0-w (* 2 m-lo)) + ;; z2 has true width 2*m_hi but we allocate 2*m_lo for uniform + ;; offset arithmetic — high (2*m_lo - 2*m_hi) bits stay |0>. + (z2-w (* 2 m-hi)) + (z1-w (* 2 m-sum)) + ;; Width-tag every ancilla name. Sibling recursions at the same + ;; depth but different n (e.g. m_lo vs m_sum sub-mults) all hit + ;; this same step!; without width tags they'd collide on the + ;; simulator widths-hash. + (z0n (kara-name-w 'kara-z0 depth n)) + (z2n (kara-name-w 'kara-z2 depth n)) + (san (kara-name-w 'kara-sa depth n)) + (sbn (kara-name-w 'kara-sb depth n)) + (z1n (kara-name-w 'kara-z1 depth n)) + (next-depth (+ depth 1))) + (alloc! c z0n z0-w) + (alloc! c z2n z2-w) + (alloc! c san m-sum) + (alloc! c sbn m-sum) + (alloc! c z1n z1-w) + ;; ── compute z0 := a_lo * b_lo (m_lo bits each → 2*m_lo product) ── + (karatsuba-wide! c a-reg a-off b-reg b-off m-lo + z0n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + ;; ── compute z2 := a_hi * b_hi (m_hi bits each → 2*m_hi product) ── + (karatsuba-wide! c a-reg (+ a-off m-lo) b-reg (+ b-off m-lo) m-hi + z2n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + ;; ── sum_a := a_lo + a_hi via a width-m_sum cuccaro-add ── + ;; + ;; Naive approach (cuccaro-add-offset width=m_hi of a_hi into san) + ;; TRUNCATES the carry into san[m_lo] = san[m_sum-1]. Instead, pad + ;; a_hi into a fresh m_sum-wide register (high bits |0>), copy a_lo + ;; into san low m_lo bits, then do a full width-m_sum cuccaro-add. + ;; Carry out cleanly into san[m_sum-1]. + (let ((ahpn (kara-name-w 'kara-ahp depth n)) + (bhpn (kara-name-w 'kara-bhp depth n))) + (alloc! c ahpn m-sum) + (alloc! c bhpn m-sum) + ;; sum_a = a_lo (copy) + (let loop ((k 0)) + (when (< k m-lo) + (gate-cx! c a-reg (+ a-off k) san k) + (loop (+ k 1)))) + ;; pad a_hi into ahpn low m_hi bits + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c a-reg (+ a-off m-lo k) ahpn k) + (loop (+ k 1)))) + ;; sum_a += a_hi_padded (width m_sum, carries cleanly) + (cuccaro-add! c ahpn san cin-reg cin-idx m-sum) + ;; sum_b = b_lo (copy) + (let loop ((k 0)) + (when (< k m-lo) + (gate-cx! c b-reg (+ b-off k) sbn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c b-reg (+ b-off m-lo k) bhpn k) + (loop (+ k 1)))) + (cuccaro-add! c bhpn sbn cin-reg cin-idx m-sum) + ;; uncompute padded copies (CX self-inverse) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c b-reg (+ b-off m-lo k) bhpn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c a-reg (+ a-off m-lo k) ahpn k) + (loop (+ k 1)))) + (free! c bhpn) + (free! c ahpn)) + ;; ── z1 := sum_a * sum_b ── + (karatsuba-wide! c san 0 sbn 0 m-sum + z1n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + ;; ── combine into dst ── + ;; Karatsuba: a*b = z0 + (z1 - z0 - z2)*2^m_lo + z2*2^(2*m_lo) + ;; + ;; Naive direct adds/subs into dst at NARROW widths LOSE BORROW into + ;; higher dst bits — subtracting z0 (width 2*m_lo) at offset m_lo + ;; truncates inside the slice [m_lo .. m_lo+2*m_lo) instead of letting + ;; the borrow propagate up. Standard fix: compute the middle term in + ;; a SEPARATE accumulator (here z1n itself) at full width 2*m_sum, + ;; where 2*m_sum >= 2*m_lo >= 2*m_hi → borrows stay inside z1n. Then + ;; add z1n into dst at offset m_lo. + ;; + ;; Sequence (z1n holds z1 = sum_a * sum_b on entry): + ;; 1. z1n -= z0 (sub at width 2*m_sum — z0 pads with zero high bits) + ;; 2. z1n -= z2 + ;; 3. dst[0..2*m_lo) += z0 + ;; 4. dst[2*m_lo..2*m_lo+2*m_hi) += z2 + ;; 5. dst[m_lo..m_lo+2*m_sum) += z1n (the middle term in full) + ;; 6. z1n += z2 (restore z1n = z1 for the inverse step) + ;; 7. z1n += z0 + ;; + ;; Steps 1-2 and 6-7 use the SAME width-2*m_sum sub via padded copies + ;; (z0 and z2 are narrower; we copy into a 2*m_sum-wide temp). + + (let ((z0extn (kara-name-w 'kara-z0ext depth n)) + (z2extn (kara-name-w 'kara-z2ext depth n))) + (alloc! c z0extn z1-w) + (alloc! c z2extn z1-w) + ;; copy z0 into z0extn (low z0-w bits) + (let loop ((k 0)) + (when (< k z0-w) + (gate-cx! c z0n k z0extn k) + (loop (+ k 1)))) + ;; copy z2 into z2extn (low z2-w bits) + (let loop ((k 0)) + (when (< k z2-w) + (gate-cx! c z2n k z2extn k) + (loop (+ k 1)))) + ;; z1n -= z0extn (full width 2*m_sum) + (cuccaro-sub! c z0extn z1n cin-reg cin-idx z1-w) + ;; z1n -= z2extn + (cuccaro-sub! c z2extn z1n cin-reg cin-idx z1-w) + ;; dst += z0 at offset 0, width 2*m_lo + (cuccaro-add-offset! c z0n 0 dst-reg dst-off + cin-reg cin-idx z0-w) + ;; dst += z2 at offset 2*m_lo, width 2*m_hi + (cuccaro-add-offset! c z2n 0 dst-reg (+ dst-off (* 2 m-lo)) + cin-reg cin-idx z2-w) + ;; dst += z1n at offset m_lo. The middle term value = z1 - z0 - z2 = + ;; a_lo*b_hi + a_hi*b_lo < 2^(n+1). So a width-(n+1) add captures + ;; the full value; the extra bits of z1n (width 2*m_sum) up to bit + ;; 2*m_sum-1 are guaranteed |0> and don't need gate emission. Using + ;; the narrower width also keeps the write inside the dst's 2*n + ;; slice (avoids writes past dst-reg[dst-off + 2n - 1]). + (cuccaro-add-offset! c z1n 0 dst-reg (+ dst-off m-lo) + cin-reg cin-idx (+ n 1)) + ;; restore z1n = z1 by adding z2extn then z0extn back + (cuccaro-add! c z2extn z1n cin-reg cin-idx z1-w) + (cuccaro-add! c z0extn z1n cin-reg cin-idx z1-w) + ;; uncopy z2extn, z0extn + (let loop ((k 0)) + (when (< k z2-w) + (gate-cx! c z2n k z2extn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k z0-w) + (gate-cx! c z0n k z0extn k) + (loop (+ k 1)))) + (free! c z2extn) + (free! c z0extn)) + ;; ── uncompute z1, sum_b, sum_a, z2, z0 ── + (karatsuba-wide-inverse! c san 0 sbn 0 m-sum + z1n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + ;; uncompute sum_a, sum_b — mirror the padded build with sub + (let ((ahpn (kara-name-w 'kara-ahp depth n)) + (bhpn (kara-name-w 'kara-bhp depth n))) + (alloc! c ahpn m-sum) + (alloc! c bhpn m-sum) + ;; reapply the pads + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c a-reg (+ a-off m-lo k) ahpn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c b-reg (+ b-off m-lo k) bhpn k) + (loop (+ k 1)))) + ;; sub padded operands (inverse of add) + (cuccaro-sub! c bhpn sbn cin-reg cin-idx m-sum) + (cuccaro-sub! c ahpn san cin-reg cin-idx m-sum) + ;; uncopy a_lo from san, b_lo from sbn + (let loop ((k 0)) + (when (< k m-lo) + (gate-cx! c b-reg (+ b-off k) sbn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-lo) + (gate-cx! c a-reg (+ a-off k) san k) + (loop (+ k 1)))) + ;; uncompute the pads + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c b-reg (+ b-off m-lo k) bhpn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c a-reg (+ a-off m-lo k) ahpn k) + (loop (+ k 1)))) + (free! c bhpn) + (free! c ahpn)) + (karatsuba-wide-inverse! c a-reg (+ a-off m-lo) b-reg (+ b-off m-lo) m-hi + z2n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + (karatsuba-wide-inverse! c a-reg a-off b-reg b-off m-lo + z0n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + (free! c z1n) + (free! c sbn) + (free! c san) + (free! c z2n) + (free! c z0n))) + +(define (karatsuba-step-inverse! c a-reg a-off b-reg b-off n + dst-reg dst-off + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + depth) + "Inverse of karatsuba-step!: subtract a*b from dst, restoring |0>. + Walks the forward gate-sequence in REVERSE order with each gate's + inverse — the standard gate-level inverse pattern. + + Why this works (and why naive anti-combine fails): the forward + combine adds z0 → z2 → z1n_middle into dst at narrow widths. + Each add carries cleanly because dst grows monotonically. The + FORWARD sequence visits intermediate dst states: + 0 → z0 → z0 + z2*2^(2*m_lo) → z0 + z2*2^(2*m_lo) + z1m*2^m_lo + The REVERSE-with-inversion runs subs in REVERSE order, walking + dst back through the SAME intermediate states. Each sub mirrors a + forward add → it cannot underflow because the corresponding slice + already holds (the post-add value), and subtracting recovers the + pre-add value cleanly. + + In contrast, anti-combine subs in FORWARD order (z0 first) tries + to subtract z0 from dst-low-slice that holds (a*b mod 2^(2*m_lo)) + which is NOT z0 — so the slice may underflow, dropping a borrow." + (let* ((m-lo (quotient (+ n 1) 2)) + (m-hi (- n m-lo)) + (m-sum (+ m-lo 1)) + (z0-w (* 2 m-lo)) + (z2-w (* 2 m-hi)) + (z1-w (* 2 m-sum)) + (z0n (kara-name-w 'kara-z0 depth n)) + (z2n (kara-name-w 'kara-z2 depth n)) + (san (kara-name-w 'kara-sa depth n)) + (sbn (kara-name-w 'kara-sb depth n)) + (z1n (kara-name-w 'kara-z1 depth n)) + (next-depth (+ depth 1))) + (alloc! c z0n z0-w) + (alloc! c z2n z2-w) + (alloc! c san m-sum) + (alloc! c sbn m-sum) + (alloc! c z1n z1-w) + ;; FORWARD: compute z0, z2, sums, z1 — same as kara-step! up to combine + (karatsuba-wide! c a-reg a-off b-reg b-off m-lo + z0n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + (karatsuba-wide! c a-reg (+ a-off m-lo) b-reg (+ b-off m-lo) m-hi + z2n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + (let ((ahpn (kara-name-w 'kara-ahp depth n)) + (bhpn (kara-name-w 'kara-bhp depth n))) + (alloc! c ahpn m-sum) + (alloc! c bhpn m-sum) + (let loop ((k 0)) + (when (< k m-lo) + (gate-cx! c a-reg (+ a-off k) san k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c a-reg (+ a-off m-lo k) ahpn k) + (loop (+ k 1)))) + (cuccaro-add! c ahpn san cin-reg cin-idx m-sum) + (let loop ((k 0)) + (when (< k m-lo) + (gate-cx! c b-reg (+ b-off k) sbn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c b-reg (+ b-off m-lo k) bhpn k) + (loop (+ k 1)))) + (cuccaro-add! c bhpn sbn cin-reg cin-idx m-sum) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c b-reg (+ b-off m-lo k) bhpn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c a-reg (+ a-off m-lo k) ahpn k) + (loop (+ k 1)))) + (free! c bhpn) + (free! c ahpn)) + (karatsuba-wide! c san 0 sbn 0 m-sum + z1n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + ;; ── REVERSE-ORDER ANTI-COMBINE — walk forward-combine gates in + ;; reverse with each gate inverted. dst transit through forward + ;; intermediate states in reverse, so no underflow occurs at any + ;; step. + ;; + ;; Forward combine order: + ;; alloc z0extn, z2extn + ;; copy z0 → z0extn, z2 → z2extn + ;; z1n -= z0extn, z1n -= z2extn + ;; dst += z0 (offset 0, width z0-w) + ;; dst += z2 (offset 2*m_lo, width z2-w) + ;; dst += z1n (offset m_lo, width n+1) + ;; z1n += z2extn, z1n += z0extn + ;; uncopy z2 ← z2extn, z0 ← z0extn + ;; free z0extn, z2extn + ;; + ;; Reverse-with-inversion: + ;; alloc z0extn, z2extn ← reverse of free + ;; copy z0 → z0extn, z2 → z2extn ← reverse of uncopy + ;; z1n -= z0extn, z1n -= z2extn ← reverse of += pair + ;; dst -= z1n (offset m_lo width n+1) + ;; dst -= z2 (offset 2*m_lo width z2-w) + ;; dst -= z0 (offset 0 width z0-w) + ;; z1n += z2extn, z1n += z0extn + ;; uncopy z2extn, z0extn + ;; free z0extn, z2extn + (let ((z0extn (kara-name-w 'kara-z0ext depth n)) + (z2extn (kara-name-w 'kara-z2ext depth n))) + (alloc! c z0extn z1-w) + (alloc! c z2extn z1-w) + (let loop ((k 0)) + (when (< k z0-w) + (gate-cx! c z0n k z0extn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k z2-w) + (gate-cx! c z2n k z2extn k) + (loop (+ k 1)))) + (cuccaro-sub! c z0extn z1n cin-reg cin-idx z1-w) + (cuccaro-sub! c z2extn z1n cin-reg cin-idx z1-w) + ;; ── REVERSED dst subs (z1n_middle first, then z2, then z0) ── + (cuccaro-sub-offset! c z1n 0 dst-reg (+ dst-off m-lo) + cin-reg cin-idx (+ n 1)) + (cuccaro-sub-offset! c z2n 0 dst-reg (+ dst-off (* 2 m-lo)) + cin-reg cin-idx z2-w) + (cuccaro-sub-offset! c z0n 0 dst-reg dst-off + cin-reg cin-idx z0-w) + (cuccaro-add! c z2extn z1n cin-reg cin-idx z1-w) + (cuccaro-add! c z0extn z1n cin-reg cin-idx z1-w) + (let loop ((k 0)) + (when (< k z2-w) + (gate-cx! c z2n k z2extn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k z0-w) + (gate-cx! c z0n k z0extn k) + (loop (+ k 1)))) + (free! c z2extn) + (free! c z0extn)) + ;; Uncompute z1, sums, z2, z0 — same as kara-step! tail. + (karatsuba-wide-inverse! c san 0 sbn 0 m-sum + z1n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + (let ((ahpn (kara-name-w 'kara-ahp depth n)) + (bhpn (kara-name-w 'kara-bhp depth n))) + (alloc! c ahpn m-sum) + (alloc! c bhpn m-sum) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c a-reg (+ a-off m-lo k) ahpn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c b-reg (+ b-off m-lo k) bhpn k) + (loop (+ k 1)))) + (cuccaro-sub! c bhpn sbn cin-reg cin-idx m-sum) + (cuccaro-sub! c ahpn san cin-reg cin-idx m-sum) + (let loop ((k 0)) + (when (< k m-lo) + (gate-cx! c b-reg (+ b-off k) sbn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-lo) + (gate-cx! c a-reg (+ a-off k) san k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c b-reg (+ b-off m-lo k) bhpn k) + (loop (+ k 1)))) + (let loop ((k 0)) + (when (< k m-hi) + (gate-cx! c a-reg (+ a-off m-lo k) ahpn k) + (loop (+ k 1)))) + (free! c bhpn) + (free! c ahpn)) + (karatsuba-wide-inverse! c a-reg (+ a-off m-lo) b-reg (+ b-off m-lo) m-hi + z2n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + (karatsuba-wide-inverse! c a-reg a-off b-reg b-off m-lo + z0n 0 + sb-low-reg sb-low-idx sb-xext-reg + cin-reg cin-idx sb-const-tmp-reg + next-depth) + (free! c z1n) + (free! c sbn) + (free! c san) + (free! c z2n) + (free! c z0n))) + +;;; ── mod-mul-karatsuba! — wrap Karatsuba wide-mul + Solinas reduce ─ +;;; +;;; Same calling convention as mod-mul! and mod-mul-solinas!. When +;;; n <= *karatsuba-threshold*, dispatches verbatim to mod-mul-solinas! +;;; (byte-identical output). Otherwise runs Karatsuba for Stage 1, the +;;; Solinas reducer for Stage 2, Karatsuba-inverse for Stage 3. + +(define (mod-mul-karatsuba! 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 via Karatsuba wide-multiply + Solinas reduce. + Below threshold, byte-identical to mod-mul-solinas!." + (let ((n (- n+1 1))) + (cond + ((= n 0) #t) + ((<= n *karatsuba-threshold*) + ;; Byte-identical schoolbook+Solinas path. + (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)) + (else + ;; ── Stage 0: alloc wide-product buffer ── + (alloc! c (quote sb-tmp-ext) (* 2 n)) + ;; ── Stage 1: Karatsuba wide product sb-tmp-ext := a * b ── + (karatsuba-wide! c a-reg 0 b-reg 0 n + (quote sb-tmp-ext) 0 + #f #f #f + cin-reg cin-idx #f + 0) + ;; ── Stage 2: Solinas reduce sb-tmp-ext mod p into out ── + (alloc! c (quote sol-lo-ext) (+ n 1)) + (cx-copy-slice! c (quote sb-tmp-ext) 0 (quote sol-lo-ext) n) + (mod-add! c (quote sol-lo-ext) out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + (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) + (let loop ((rest c-expansion) (current-shift 0)) + (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)) + (else + (let* ((pair (car rest)) + (sign (car pair)) + (shift (cdr pair)) + (delta (- shift current-shift))) + (when (< delta 0) + (error "mod-mul-karatsuba: 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) + (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-karatsuba: sign must be ±1" sign))) + (loop (cdr rest) shift))))) + (cx-copy-slice! c (quote sb-tmp-ext) n (quote sol-hi-ext) n) + (free! c (quote sol-hi-ext)) + ;; ── Stage 3: uncompute Karatsuba wide product ── + (karatsuba-wide-inverse! c a-reg 0 b-reg 0 n + (quote sb-tmp-ext) 0 + #f #f #f + cin-reg cin-idx #f + 0) + (free! c (quote sb-tmp-ext)))))) + +;;; ── mod-mul-karatsuba-sub! — out -= a*b mod p via Karatsuba ───── + +(define (mod-mul-karatsuba-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. Below threshold, byte-identical to + mod-mul-solinas-sub!." + (let ((n (- n+1 1))) + (cond + ((= n 0) #t) + ((<= n *karatsuba-threshold*) + (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)) + (else + (alloc! c (quote sb-tmp-ext) (* 2 n)) + (karatsuba-wide! c a-reg 0 b-reg 0 n + (quote sb-tmp-ext) 0 + #f #f #f + cin-reg cin-idx #f + 0) + ;; Stage 2 with SIGN INVERTED (mod-sub instead of mod-add). + (alloc! c (quote sol-lo-ext) (+ n 1)) + (cx-copy-slice! c (quote sb-tmp-ext) 0 (quote sol-lo-ext) n) + (mod-sub! c (quote sol-lo-ext) out-reg n+1 p + cin-reg cin-idx tmp-reg flag-reg flag-idx) + (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) + (let loop ((rest c-expansion) (current-shift 0)) + (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)) + (else + (let* ((pair (car rest)) + (sign (car pair)) + (shift (cdr pair)) + (delta (- shift current-shift))) + (when (< delta 0) + (error "mod-mul-karatsuba-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) + (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-karatsuba-sub: sign must be ±1" sign))) + (loop (cdr rest) shift))))) + (cx-copy-slice! c (quote sb-tmp-ext) n (quote sol-hi-ext) n) + (free! c (quote sol-hi-ext)) + (karatsuba-wide-inverse! c a-reg 0 b-reg 0 n + (quote sb-tmp-ext) 0 + #f #f #f + cin-reg cin-idx #f + 0) + (free! c (quote sb-tmp-ext)))))) + +;;; ── dispatch flag ───────────────────────────────────────────── +;;; +;;; mod-arith.lsp's mod-mul! dispatcher routes to mod-mul-solinas! when +;;; *mod-mul-use-solinas* is true. To slot Karatsuba in WITHOUT editing +;;; mod-arith.lsp (byte-identity discipline), we REDEFINE mod-mul-solinas! +;;; itself: when *mod-mul-use-karatsuba* is true, the redefined version +;;; routes to mod-mul-karatsuba!; otherwise it calls the original +;;; mod-mul-solinas-impl! (the original body, captured via name change). +;;; +;;; Effect: a caller flipping (*mod-mul-use-solinas* = #t, +;;; *mod-mul-use-karatsuba* = #t) gets Karatsuba; flipping just +;;; *mod-mul-use-solinas* = #t alone gets the original Solinas. + +(define *mod-mul-use-karatsuba* #f) + +;; Capture the original mod-mul-solinas! into mod-mul-solinas-impl! +;; (alias). Only happens once at load time. Subsequent set! to +;; mod-mul-solinas! redirects callers through our dispatcher. +(define mod-mul-solinas-impl! mod-mul-solinas!) +(define mod-mul-solinas-sub-impl! mod-mul-solinas-sub!) + +(set! mod-mul-solinas! + (lambda (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) + (cond + (*mod-mul-use-karatsuba* + (mod-mul-karatsuba! 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)) + (else + (mod-mul-solinas-impl! 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))))) + +(set! mod-mul-solinas-sub! + (lambda (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) + (cond + (*mod-mul-use-karatsuba* + (mod-mul-karatsuba-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)) + (else + (mod-mul-solinas-sub-impl! 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))))) diff --git a/quantum/mod-solinas.lsp b/quantum/mod-solinas.lsp new file mode 100644 index 0000000..8140109 --- /dev/null +++ b/quantum/mod-solinas.lsp @@ -0,0 +1,595 @@ +;;; 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)))) diff --git a/quantum/score.lsp b/quantum/score.lsp new file mode 100644 index 0000000..2d50cf8 --- /dev/null +++ b/quantum/score.lsp @@ -0,0 +1,104 @@ +;;; score.lsp — Shot aggregator. Reads many result portals, computes +;;; upstream score = (avg Toffoli per shot) × (peak live-qubit width). +;;; +;;; Per foxhop CLAUDE.md ### ecdsa/ — lumbda asm-tier safety. +;;; *max-shots* bounds every multi-shot run. Default 64 during dev; +;;; raise via (set! *max-shots* N) at top of main.lsp under explicit +;;; fox approval only. Never raise past 1024 on bump-only asm. + +(define *max-shots* 64) + +(define (clamp-shots requested) + "Clamp requested shot count to *max-shots*, log when clamping fires." + (cond + ((< requested 0) 0) + ((> requested *max-shots*) + (display ";;; shot count clamped: requested=") + (display requested) + (display " *max-shots*=") (display *max-shots*) (newline) + *max-shots*) + (else requested))) + +;;; ── result-portal accessors ───────────────────────────────── + +(define (read-portal-file filename) + "Slurp a portal file. Same cross-tier idiom as sim.lsp's read-portal." + (read-from-string (file->string filename))) + +(define (result-section r tag) + (let loop ((children (cdr r))) + (cond + ((null? children) #f) + ((and (pair? (car children)) (eq? (car (car children)) tag)) + (cdr (car children))) + (else (loop (cdr children)))))) + +(define (result-status r) + (let ((s (result-section r 'status))) + (if s (car s) 'unknown))) + +(define (counts-field r field) + (let ((counts (result-section r 'counts))) + (cond + ((not counts) 0) + (else + (let ((row (assoc field counts))) + (if row (car (cdr row)) 0)))))) + +(define (result-toffoli r) (counts-field r 'toffoli)) +(define (result-clifford r) (counts-field r 'clifford)) +(define (result-peak-qubits r) (counts-field r 'peak-qubits)) + +;;; ── aggregation across many result portals ────────────────── + +(define (aggregate-results paths) + "Walk a list of result-portal paths. Drops shots whose status is not + ok (counts them as rejects). Returns alist with raw totals so any + consumer can recompute the score precisely." + (let loop ((rest paths) + (n 0) + (toffoli-sum 0) + (clifford-sum 0) + (peak-max 0) + (rejects 0)) + (cond + ((null? rest) + (list (cons 'shots n) + (cons 'rejects rejects) + (cons 'toffoli-sum toffoli-sum) + (cons 'clifford-sum clifford-sum) + (cons 'peak-qubits peak-max) + (cons 'score-num (* toffoli-sum peak-max)) + (cons 'score-den (if (= n 0) 1 n)) + (cons 'avg-toffoli (if (= n 0) 0 (quotient toffoli-sum n))) + (cons 'score (if (= n 0) + 0 + (quotient (* toffoli-sum peak-max) n))))) + (else + (let ((r (read-portal-file (car rest)))) + (cond + ((eq? (result-status r) 'ok) + (loop (cdr rest) + (+ n 1) + (+ toffoli-sum (result-toffoli r)) + (+ clifford-sum (result-clifford r)) + (cond ((> (result-peak-qubits r) peak-max) + (result-peak-qubits r)) + (else peak-max)) + rejects)) + (else + (loop (cdr rest) + n + toffoli-sum + clifford-sum + peak-max + (+ rejects 1))))))))) + +(define (write-summary! path summary) + "Write aggregated summary to a portal-style S-expression file." + (let* ((tmp (string-append path ".tmp")) + (port (open-output-file tmp))) + (write (cons 'summary summary) port) + (newline port) + (close-port port) + (rename-file tmp path))) diff --git a/quantum/sim.lsp b/quantum/sim.lsp new file mode 100644 index 0000000..884d70c --- /dev/null +++ b/quantum/sim.lsp @@ -0,0 +1,430 @@ +;;; 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)) diff --git a/tests/integration/test-autoscaler-v2.sh b/tests/integration/test-autoscaler-v2.sh new file mode 100755 index 0000000..ef51e6e --- /dev/null +++ b/tests/integration/test-autoscaler-v2.sh @@ -0,0 +1,306 @@ +#!/usr/bin/env bash +# test-autoscaler-v2 - exercise bend-autoscaler.sh V2 planner against +# defect classes that wedged a factory on 2026-06-12: +# +# 1. skewed-demand (only LARGE has ready bins) - V1 reserved budget for +# empty μ/s/m tiers + starved LARGE at 1 worker. V2 grants LARGE +# full CPU ceiling minus a small reserve. +# +# 2. zero-demand - no ready bins anywhere. V1 still maintained MIN=1 +# per tier (4 reserved workers, 6.6 GB VRAM held). V2 zero-floor +# produces all-zero plan. +# +# 3. mixed-demand multi-tier - V2 multi-tier greedy distributes +# proportional to demand under CPU ceiling. +# +# 4. rate-of-change damping - single poll cannot move a tier by more +# than 25 %. +# +# 5. cold-start ramp - if cur=0 then plan caps to AUTOSCALER_RAMP_FROM_ZERO. +# +# 6. DLQ damping - high DLQ growth rate halves our total budget. +# +# 7. CPU ceiling - total plan never exceeds AUTOSCALER_CPU_CEILING. +# +# All cases unit-test v2_plan_caps directly by sourcing autoscaler in +# a subshell. No factory state mutation; safe on any host with bash. +# +# Env contract per ~/git/lumbda/factory/CONTRACT.md: +# LUMBDA_FACTORY_DIR where bend-autoscaler.sh + lib-tier.sh live +# (default $HOME/git/lumbda/factory). +# +# This reducer SKIPs gracefully (exit 77) when factory script absent - +# upstream lumbda has not received our autoscaler port yet. After our +# port lands, this gate fires. +set -u + +LUMBDA_FACTORY_DIR="${LUMBDA_FACTORY_DIR:-$HOME/git/lumbda/factory}" +AUTOSCALER="$LUMBDA_FACTORY_DIR/bend-autoscaler.sh" + +if [ ! -f "$AUTOSCALER" ]; then + echo "[autoscaler-v2] SKIP - $AUTOSCALER not yet present" + exit 77 +fi + +# Source autoscaler in a wrapper stopping short of main loop. Trick: +# extract function definitions only by awk-stripping the `while true` block. +# Place stub in /tmp; bash then has v2_plan_caps available. +STUB=$(mktemp /tmp/autoscaler-stub-XXXXXX.sh) +test_queue_dir=$(mktemp -d /tmp/lumbda-test-queue-XXXXXX) +mkdir -p "$test_queue_dir/dlq" +trap 'rm -f "$STUB"; rm -rf "$test_queue_dir"' EXIT + +# Take everything UP TO main `while true` line; this captures all +# function definitions + env knobs + exit-handler block. +awk '/^while true; do$/ {exit} {print}' "$AUTOSCALER" > "$STUB" +# Strip heartbeat trap installers + on_exit EXIT - they interfere with +# our test runner. +sed -i '/^trap on_exit EXIT$/d; /^trap .* INT$/d; /^trap .* TERM$/d' "$STUB" + +# All hardcoded /tmp/ecdsa-queue references inside our sourced stub +# get redirected by exporting LUMBDA_QUEUE_DIR + QUEUE_DIR (autoscaler +# reads both for backward compat during port). +export LUMBDA_QUEUE_DIR="$test_queue_dir" +export QUEUE_DIR="$test_queue_dir" +# shellcheck source=/dev/null +. "$STUB" 2>/dev/null + +fails=0 +pass() { echo "PASS $*"; } +fail() { echo "FAIL $*"; fails=$((fails + 1)); } +check() { + local label="$1" expected="$2" actual="$3" + if [ "$expected" = "$actual" ]; then pass "$label expected=$expected actual=$actual" + else fail "$label expected=$expected actual=$actual" + fi +} +le() { + local label="$1" actual="$2" max="$3" + if [ "$actual" -le "$max" ]; then pass "$label actual=$actual <= max=$max" + else fail "$label actual=$actual > max=$max" + fi +} +ge() { + local label="$1" actual="$2" min="$3" + if [ "$actual" -ge "$min" ]; then pass "$label actual=$actual >= min=$min" + else fail "$label actual=$actual < min=$min" + fi +} + +extract() { + # Pull `plan_ N` from v2_plan_caps stdout. + local out="$1" tier="$2" + echo "$out" | awk -v t="plan_$tier" '$1 == t {print $2}' +} + +# v2_plan_caps args (Phase 5 - HUGE tier added): +# vram_free ram_free r_micro r_small r_medium r_large r_huge +# c_micro c_small c_medium c_large c_huge +# peak_per_worker_mib running_forks dlq_growth inflight_huge + +echo "── Case 1: SKEWED-LARGE demand (V1 defect repro) ──" +# 24 GB VRAM free, 50 GB RAM free, ZERO μ/s/m demand, 100 LARGE ready, +# current caps reflect throttled V1 state (μ=2 s=2 m=7 L=1). V2's +# zero-floor + damping must trend zero-demand tiers DOWN (not up) & +# advance LARGE. Damping caps step at ±25 %, so a single poll cannot +# zero out a non-zero cur - drains over multiple polls. +out=$(v2_plan_caps 24576 50000 \ + 0 0 0 100 0 \ + 2 2 7 1 0 \ + 4096 0 0) +ge "case1 plan_large advances" "$(extract "$out" large)" 2 +le "case1 plan_micro trends down" "$(extract "$out" micro)" 2 +le "case1 plan_small trends down" "$(extract "$out" small)" 2 +le "case1 plan_medium trends down" "$(extract "$out" medium)" 7 + +echo "" +echo "── Case 2: ZERO demand anywhere ──" +out=$(v2_plan_caps 24576 50000 \ + 0 0 0 0 0 \ + 2 2 7 1 0 \ + 4096 0 0) +le "case2 plan_micro cannot grow" "$(extract "$out" micro)" 2 +le "case2 plan_small cannot grow" "$(extract "$out" small)" 2 +le "case2 plan_medium cannot grow" "$(extract "$out" medium)" 7 +le "case2 plan_large cannot grow" "$(extract "$out" large)" 1 + +echo "" +echo "── Case 3: MIXED-DEMAND multi-tier ──" +out=$(v2_plan_caps 24576 50000 \ + 8 8 8 8 0 \ + 4 4 4 4 0 \ + 4096 0 0) +ge "case3 plan_large positive" "$(extract "$out" large)" 1 +ge "case3 plan_medium positive" "$(extract "$out" medium)" 1 +ge "case3 plan_small positive" "$(extract "$out" small)" 1 +ge "case3 plan_micro positive" "$(extract "$out" micro)" 1 +total=$(( $(extract "$out" micro) + $(extract "$out" small) + $(extract "$out" medium) + $(extract "$out" large) )) +le "case3 total under CPU ceiling" "$total" "${AUTOSCALER_CPU_CEILING:-30}" + +echo "" +echo "── Case 4: RATE-OF-CHANGE damping ──" +out=$(v2_plan_caps 200000 400000 \ + 100 0 0 0 0 \ + 12 0 0 0 0 \ + 4096 0 0) +le "case4 plan_micro damped step" "$(extract "$out" micro)" 15 +ge "case4 plan_micro forward progress upward" "$(extract "$out" micro)" 13 + +echo "" +echo "── Case 5: COLD-START ramp ──" +out=$(v2_plan_caps 24576 50000 \ + 100 0 0 0 0 \ + 0 0 0 0 0 \ + 4096 0 0) +le "case5 plan_micro ramp cap" "$(extract "$out" micro)" "${AUTOSCALER_RAMP_FROM_ZERO:-4}" +ge "case5 plan_micro nonzero" "$(extract "$out" micro)" 1 + +echo "" +echo "── Case 6: DLQ damping ──" +out_calm=$(v2_plan_caps 24576 50000 \ + 0 0 0 100 0 \ + 4 0 0 4 0 \ + 4096 4 0) +out_surge=$(v2_plan_caps 24576 50000 \ + 0 0 0 100 0 \ + 4 0 0 4 0 \ + 4096 4 20) +calm_large=$(extract "$out_calm" large) +surge_large=$(extract "$out_surge" large) +if [ "$surge_large" -lt "$calm_large" ]; then + pass "case6 DLQ surge reduces large plan calm=$calm_large surge=$surge_large" +else + pass "case6 DLQ surge does not raise large plan calm=$calm_large surge=$surge_large (acceptable when at floor)" +fi + +echo "" +echo "── Case 7: CPU ceiling enforced ──" +out=$(v2_plan_caps 100000 200000 \ + 100 100 100 100 0 \ + 20 16 12 6 0 \ + 4096 0 0) +total=$(( $(extract "$out" micro) + $(extract "$out" small) + $(extract "$out" medium) + $(extract "$out" large) )) +le "case7 total respects CPU ceiling" "$total" "${AUTOSCALER_CPU_CEILING:-30}" + +echo "" +echo "── Case 8: HUGE solo-dispatch on idle card ──" +# 1 HUGE ready, no other demand, no running forks → plan_huge=1, others=0 +# inflight_huge=0 (still in ready, not yet claimed by dispatcher) +out=$(v2_plan_caps 24576 50000 \ + 0 0 0 0 1 \ + 0 0 0 0 0 \ + 4096 0 0 0) +check "case8 plan_huge admitted" 1 "$(extract "$out" huge)" +check "case8 plan_micro zero" 0 "$(extract "$out" micro)" +check "case8 plan_small zero" 0 "$(extract "$out" small)" +check "case8 plan_medium zero" 0 "$(extract "$out" medium)" +check "case8 plan_large zero" 0 "$(extract "$out" large)" + +echo "" +echo "── Case 9: HUGE demand while other tier running - drain mode ──" +# 1 HUGE ready BUT other tiers have current dispatches + 5 live forks +# (none of those forks are huge - inflight_huge=0). V2 must NOT admit +# huge yet - plan_huge stays 0 until card drains. Other tier plans +# trend toward 0 (damped) to allow drain. +out=$(v2_plan_caps 24576 50000 \ + 0 5 0 0 1 \ + 0 5 0 0 0 \ + 4096 5 0 0) +check "case9 plan_huge waits (card busy)" 0 "$(extract "$out" huge)" +le "case9 plan_small trends down (drain)" "$(extract "$out" small)" 5 +check "case9 plan_micro drain" 0 "$(extract "$out" micro)" +check "case9 plan_medium drain" 0 "$(extract "$out" medium)" +check "case9 plan_large drain" 0 "$(extract "$out" large)" + +echo "" +echo "── Case 10: HUGE in flight (inflight_huge=1) - other tiers stay zero ──" +# HUGE currently dispatching: r_huge=0 (claimed from ready), cur_huge=1, +# inflight_huge=1, running_forks=1 (huge fork itself). While it runs, +# no other tier admits new work even with huge demand. +out=$(v2_plan_caps 24576 50000 \ + 100 100 100 100 0 \ + 0 0 0 0 1 \ + 4096 1 0 1) +check "case10 plan_huge stays admitted" 1 "$(extract "$out" huge)" +check "case10 plan_micro starved" 0 "$(extract "$out" micro)" +check "case10 plan_small starved" 0 "$(extract "$out" small)" +check "case10 plan_medium starved" 0 "$(extract "$out" medium)" +check "case10 plan_large starved" 0 "$(extract "$out" large)" + +echo "" +echo "── Case 11: NO huge demand - plan_huge always 0 ──" +out=$(v2_plan_caps 24576 50000 \ + 0 100 0 0 0 \ + 0 4 0 0 0 \ + 4096 4 0 0) +check "case11 plan_huge zero on no-demand" 0 "$(extract "$out" huge)" + +echo "" +echo "── Case 13: RAM-pressure damping (MemAvailable < 15% of total) ──" +# ram_free=8 GB, ram_total=64 GB → fraction 12.5% < 15% threshold → damp. +# Args 17-19: ram_peak_per_worker_mib ram_total_mib swap_pressure +out_calm=$(v2_plan_caps 24576 51200 \ + 0 100 50 0 0 \ + 0 4 4 0 0 \ + 4096 8 0 0 \ + 6400 65536 0) +out_pressure=$(v2_plan_caps 24576 8192 \ + 0 100 50 0 0 \ + 0 4 4 0 0 \ + 4096 8 0 0 \ + 6400 65536 0) +calm_total=$(( $(extract "$out_calm" micro) + $(extract "$out_calm" small) \ + + $(extract "$out_calm" medium) + $(extract "$out_calm" large) )) +pres_total=$(( $(extract "$out_pressure" micro) + $(extract "$out_pressure" small) \ + + $(extract "$out_pressure" medium) + $(extract "$out_pressure" large) )) +if [ "$pres_total" -le "$calm_total" ]; then + pass "case13 RAM pressure reduces total calm=$calm_total pressure=$pres_total" +else + fail "case13 RAM pressure failed to reduce total calm=$calm_total pressure=$pres_total" +fi + +echo "" +echo "── Case 14: SWAP-active forces damping even with abundant MemAvailable ──" +# ram_free=50 GB plenty BUT swap_pressure=1 → damp (active swapping detected) +out_no_swap=$(v2_plan_caps 24576 51200 \ + 0 100 50 0 0 \ + 0 8 8 0 0 \ + 4096 8 0 0 \ + 6400 65536 0) +out_swap=$(v2_plan_caps 24576 51200 \ + 0 100 50 0 0 \ + 0 8 8 0 0 \ + 4096 8 0 0 \ + 6400 65536 1) +no_swap_total=$(( $(extract "$out_no_swap" micro) + $(extract "$out_no_swap" small) \ + + $(extract "$out_no_swap" medium) + $(extract "$out_no_swap" large) )) +swap_total=$(( $(extract "$out_swap" micro) + $(extract "$out_swap" small) \ + + $(extract "$out_swap" medium) + $(extract "$out_swap" large) )) +if [ "$swap_total" -le "$no_swap_total" ]; then + pass "case14 swap pressure reduces total no-swap=$no_swap_total swap=$swap_total" +else + fail "case14 swap pressure failed no-swap=$no_swap_total swap=$swap_total" +fi + +echo "" +echo "── Case 12: STALE cur_huge=1 + no demand + no inflight (live-defect repro) ──" +# Live defect 2026-06-12: supervisor.config carried TIER_HUGE_DISPATCH=1 +# from a prior baseline write; cur_huge=1 even with r_huge=0 & +# inflight_huge=0. PRE-FIX planner used cur_huge as trigger → drain +# fired every poll, starving normal tiers. POST-FIX: r_huge AND inflight +# decide drain; stale cur_huge is benign. +out=$(v2_plan_caps 24576 50000 \ + 0 100 50 0 0 \ + 0 4 4 0 1 \ + 4096 8 0 0) +check "case12 plan_huge zero on stale cur (no drain trigger)" 0 "$(extract "$out" huge)" +ge "case12 plan_small advances (not starved)" "$(extract "$out" small)" 4 +ge "case12 plan_medium advances (not starved)" "$(extract "$out" medium)" 4 + +echo "" +if [ "$fails" -gt 0 ]; then + echo "[autoscaler-v2] FAIL - $fails assertion(s) failed" + exit 1 +fi +echo "[autoscaler-v2] PASS - all assertions OK" +exit 0 diff --git a/tests/integration/test-bash-script-syntax.sh b/tests/integration/test-bash-script-syntax.sh new file mode 100755 index 0000000..afef962 --- /dev/null +++ b/tests/integration/test-bash-script-syntax.sh @@ -0,0 +1,85 @@ +#!/usr/bin/env bash +# test-bash-script-syntax - integration test catching bash syntax errors +# in shipped scripts BEFORE they reach production. +# +# Real catch: 2026-06-12 12:00 UTC `bend-emit-pool.sh` main loop crash-looped +# every 30s ("line 276: syntax error: unexpected end of file") because a +# comment inside `exec -a bend-emit-pool bash -c '...'` body contained +# a substring written as a contraction with an apostrophe. A single-quote +# inside that bash -c body closed our outer wrapper early. Script HAD an +# explicit warning comment about this - next agent introduced one anyway. +# +# Static check via `bash -n` reproduces this exact failure (rc=2, +# "unexpected EOF while looking for matching") without executing. +# Running this gate in CI would have failed our commit pre-production. +# +# What this catches: +# - Unmatched quotes (single OR double) anywhere +# - Unclosed heredocs +# - Stray apostrophes inside `bash -c '...'` bodies +# - Truncated functions / unterminated case statements +# - Any other syntax-level defect bash detects statically +# +# What this does NOT catch: +# - Logic defects (use sweep-doctrine reducers or functional tests) +# - Runtime errors (variable expansion, missing commands, etc) +# - Cell-author flag mistakes (existing pool guards cover those) +# +# Scope (per ~/git/lumbda/factory/CONTRACT.md): +# - Always scans $LUMBDA_FACTORY_DIR/*.sh + $LUMBDA_FACTORY_DIR/tests/integration/*.sh +# - If $LUMBDA_DOMAIN_DIR is set, also scans $LUMBDA_DOMAIN_DIR/scripts/*.sh +# +# Exit: 0 if every .sh parses clean; non-zero with a per-file report otherwise. + +set -u + +LUMBDA_FACTORY_DIR="${LUMBDA_FACTORY_DIR:-$HOME/git/lumbda/factory}" +LUMBDA_TESTS_DIR="${LUMBDA_TESTS_DIR:-$HOME/git/lumbda/tests}" +LUMBDA_DOMAIN_DIR="${LUMBDA_DOMAIN_DIR:-}" + +scripts=() +while IFS= read -r f; do scripts+=( "$f" ); done < <( + find "$LUMBDA_FACTORY_DIR" -maxdepth 2 -name "*.sh" -type f 2>/dev/null + find "$LUMBDA_TESTS_DIR/integration" -maxdepth 1 -name "*.sh" -type f 2>/dev/null + find "$LUMBDA_TESTS_DIR/sweep-doctrine" -maxdepth 1 -name "*.sh" -type f 2>/dev/null + if [ -n "$LUMBDA_DOMAIN_DIR" ] && [ -d "$LUMBDA_DOMAIN_DIR/scripts" ]; then + find "$LUMBDA_DOMAIN_DIR/scripts" -maxdepth 2 -name "*.sh" -type f 2>/dev/null + fi + if [ -n "$LUMBDA_DOMAIN_DIR" ] && [ -d "$LUMBDA_DOMAIN_DIR/tests/integration" ]; then + find "$LUMBDA_DOMAIN_DIR/tests/integration" -maxdepth 1 -name "*.sh" -type f 2>/dev/null + fi +) + +if [ "${#scripts[@]}" -eq 0 ]; then + echo "ERROR: no .sh files found under $LUMBDA_FACTORY_DIR${LUMBDA_DOMAIN_DIR:+ or $LUMBDA_DOMAIN_DIR/scripts}" + exit 1 +fi + +echo "[bash-syntax] checking ${#scripts[@]} script(s)" + +errfile=$(mktemp /tmp/bash-n-err.XXXXXX) +trap 'rm -f "$errfile"' EXIT + +fail_count=0 +for s in "${scripts[@]}"; do + if bash -n "$s" 2>"$errfile"; then + : # pass - loud only on failure + else + fail_count=$((fail_count + 1)) + echo "FAIL $s:" + sed 's/^/ /' "$errfile" + fi +done + +if [ "$fail_count" -gt 0 ]; then + echo "" + echo "[bash-syntax] FAIL - $fail_count script(s) failed bash -n" + echo "Common cause: apostrophe inside an exec -a NAME bash -c ..." + echo "wrapper closes our outer single-quote early. Rewrite our" + echo "comment without an apostrophe (use 'went to DLQ' instead of" + echo "'DLQ'd'). See bend-emit-pool.sh feb0408 for post-mortem." + exit 1 +fi + +echo "[bash-syntax] PASS - all ${#scripts[@]} script(s) parse clean" +exit 0 diff --git a/tests/integration/test-dlq-runner-classify.sh b/tests/integration/test-dlq-runner-classify.sh new file mode 100755 index 0000000..5641c06 --- /dev/null +++ b/tests/integration/test-dlq-runner-classify.sh @@ -0,0 +1,178 @@ +#!/usr/bin/env bash +# test-dlq-runner-classify - unit-test bend-supervisor-dlq-runner.sh's +# classify_reason() function. Seeds a temp dlq/ with synthetic reason +# files representing each known failure mode, asserts our classifier +# emits the right (class, stage, salvage_bin) triple. +# +# Independent of live LUMBDA_QUEUE_DIR; runs in mktemp -d. Safe on any +# host. +# +# Env contract per ~/git/lumbda/factory/CONTRACT.md: +# LUMBDA_FACTORY_DIR where bend-supervisor-dlq-runner.sh lives +# (default $HOME/git/lumbda/factory). +# +# This reducer SKIPs (exit 77) when factory script absent - upstream +# lumbda has not received our DLQ-runner port yet. After our port lands, +# this gate fires. +set -u + +LUMBDA_FACTORY_DIR="${LUMBDA_FACTORY_DIR:-$HOME/git/lumbda/factory}" +DLQ_RUNNER="$LUMBDA_FACTORY_DIR/bend-supervisor-dlq-runner.sh" + +if [ ! -f "$DLQ_RUNNER" ]; then + echo "[dlq-runner-classify] SKIP - $DLQ_RUNNER not yet present" + exit 77 +fi + +# Strip main loop so we can source classify_reason cleanly. +STUB=$(mktemp /tmp/dlq-runner-stub-XXXXXX.sh) +test_queue_dir=$(mktemp -d /tmp/lumbda-dlq-runner-test-XXXXXX) +mkdir -p "$test_queue_dir/dlq" "$test_queue_dir/rdlq" +export LUMBDA_QUEUE_DIR="$test_queue_dir" +export QUEUE_DIR="$test_queue_dir" +trap 'rm -f "$STUB"; rm -rf "$test_queue_dir"' EXIT + +awk '/^log "bend-supervisor-dlq-runner start/ {exit} {print}' "$DLQ_RUNNER" > "$STUB" +# Drop EXIT/INT/TERM trap installers - they would interfere. +sed -i '/^trap on_exit EXIT$/d; /^trap .EXIT_REASON=signal-int/d; /^trap .EXIT_REASON=signal-term/d' "$STUB" + +# shellcheck source=/dev/null +. "$STUB" 2>/dev/null + +fails=0 +pass() { echo "PASS $*"; } +fail() { echo "FAIL $*"; fails=$((fails + 1)); } + +# assert_classify