russell@unturf.com
036fab47fa
The previous attempt to ship a pretty summary via an (summary "...") field inside the structured response broke on the asm (WAT) tier because read-from-string isn't a primitive there — the demo extraction fell through to the raw fallback and dumped the entire escaped S-expression. Two-part fix that works on all three tiers: http-listener (gpu-worker.lsp:1103-1116) — POST response builder now checks if the handle-request return value is a string and ships it as the raw HTTP body in that case. S-expression returns still go through write-to-string. One-line guard, no impact on ping/health/cuda-shake-fanout/cuda-sim-ops-bin which all keep returning structured S-exps. handle-cuda-secp256k1-bench — returns the formatted summary string directly instead of an (ok ... (summary ...)) wrapping. Drops the now-redundant structured fields; every number lives inside the human-readable text already. asm / c / python demo just calls (display (bend!-call "(cuda-secp256k1-bench N)")) and the formatted output panel renders identically on all tiers. Demo simplified accordingly: three (display (bend!-call …)) calls with newlines between, no read-from-string / assoc / pair? dance.
1227 lines
52 KiB
Text
1227 lines
52 KiB
Text
;;; gpu-worker.lsp -- TCP listener that dispatches bend-forms to local
|
||
;;; CUDA daemon binaries.
|
||
;;;
|
||
;;; Wire protocol: length-prefixed S-exp (see wire.lsp). Same shape
|
||
;;; the lumbda fleet workers in `ecdsa/lumbda/fleet/worker.lsp`
|
||
;;; already speak -- gpu-worker is the GPU-routing variant.
|
||
;;;
|
||
;;; Each accepted connection:
|
||
;;; 1. read one framed request (wire-recv)
|
||
;;; 2. dispatch by op head (handle-...)
|
||
;;; 3. send one framed reply (wire-send)
|
||
;;; 4. close
|
||
;;;
|
||
;;; Daemons (long-lived --daemon binaries) are held open across all
|
||
;;; connections so CUDA context init pays once per worker startup,
|
||
;;; never per request. This is the architecture that makes the bend
|
||
;;; pattern actually faster than local CPU for repeated calls.
|
||
;;;
|
||
;;; Run:
|
||
;;; lumbda gpu-worker.lsp ; default port 8320 (BEND)
|
||
;;; lumbda gpu-worker.lsp --port 9001
|
||
;;;
|
||
;;; Port mnemonic — 8320 = BEND:
|
||
;;; 8 ~= B (implied infinity B flattened; bake a cake; baby & me)
|
||
;;; 3 ~= E (backward)
|
||
;;; 2 ~= N (pivoted 90 degrees)
|
||
;;; 0 ~= D (flattened)
|
||
;;;
|
||
;;; Requires the cuda binaries on disk; paths below.
|
||
|
||
(load "wire.lsp")
|
||
(load "http-listener.lsp")
|
||
|
||
(define *worker-port* 8320)
|
||
;; HTTP listener port — defaults to wire-port + 1 so the same worker
|
||
;; serves both the native (raw wire frames) and browser (HTTP POST)
|
||
;; entry points. Browser callers (e.g. www/playground bend-url field)
|
||
;; can't open raw TCP, only HTTP/WebSocket, so the HTTP path closes
|
||
;; the on-ramp gap. Same handle-request dispatcher fires for both.
|
||
(define *worker-http-port* 8321)
|
||
(define *binary-shake-fanout*
|
||
;; Override via env or per host.
|
||
"./shake256-fanout")
|
||
|
||
;; bend-cuda lives in the foxhop ecdsa repo and runs upstream-format
|
||
;; ops.bin against the CPU+GPU simulators, writing (cuda-sim-result …)
|
||
;; portals via --portal. No daemon mode: spawn-per-call.
|
||
;; BEND_CUDA env override > default bend-cuda path. AMD ROCm path
|
||
;; will land as BEND_ROCM env / bend-rocm binary; CPU fallback BEND_CPU.
|
||
(define *binary-bend-cuda*
|
||
(or (get-environment-variable "BEND_CUDA")
|
||
"/home/fox/git/www.foxhop.net/ecdsa/cuda/bend-cuda"))
|
||
|
||
;; cgbn-batch-worker — bend form B. CGBN bignum batch over BSHK protocol;
|
||
;; daemon mode mirrors shake256-fanout.cu (process-bin <in> <out>).
|
||
(define *binary-cgbn-batch*
|
||
(or (get-environment-variable "CGBN_BATCH_WORKER")
|
||
"./cgbn-batch-worker"))
|
||
|
||
;; secp256k1-batch-mul — bend form A. Batched scalar*G on secp256k1 via
|
||
;; vendored VanitySearch-Bitcrack GPUMath.h (AGPL-3.0). Binary wire uses
|
||
;; BSCP request / BSCR response magic to stay distinct from BSHK/BCGB.
|
||
(define *binary-secp256k1-batch*
|
||
(or (get-environment-variable "SECP256K1_BATCH_WORKER")
|
||
"./secp256k1-batch-mul"))
|
||
|
||
;; radix-sort — bend form G. Batched u64 ascending sort via NVIDIA CUB
|
||
;; DeviceRadixSort (header-only, ships with CUDA Toolkit). Binary wire
|
||
;; uses BSRT request / BSRR response magic, distinct from BSHK/BCGB/BSCP.
|
||
(define *binary-radix-sort*
|
||
(or (get-environment-variable "RADIX_SORT_WORKER")
|
||
"./radix-sort"))
|
||
|
||
;; blake3-fanout — Wave-2 form `cuda-blake3-tree`. Per-input BLAKE3,
|
||
;; one CUDA thread walks the Merkle chunk tree for its input. Binary
|
||
;; wire uses BSB3 request / BSR3 response magic, distinct from all
|
||
;; other forms (BSHK/BCGB/BSCP/BSRT). Primitives vendored from
|
||
;; Blaze-3/BLAKE3-gpu (MIT); driver AGPLv3.
|
||
(define *binary-blake3-fanout*
|
||
(or (get-environment-variable "BLAKE3_FANOUT_WORKER")
|
||
"./blake3-fanout"))
|
||
|
||
(define (parse-port-arg args)
|
||
(let loop ((rest args))
|
||
(cond
|
||
((null? rest) *worker-port*)
|
||
((null? (cdr rest)) *worker-port*)
|
||
((and (string? (car rest)) (string=? (car rest) "--port"))
|
||
(or (string->number (car (cdr rest))) *worker-port*))
|
||
(else (loop (cdr rest))))))
|
||
|
||
;; HTTP port defaults to wire-port + 1. Explicit override via --http-port.
|
||
(define (parse-http-port-arg args default)
|
||
(let loop ((rest args))
|
||
(cond
|
||
((null? rest) default)
|
||
((null? (cdr rest)) default)
|
||
((and (string? (car rest)) (string=? (car rest) "--http-port"))
|
||
(or (string->number (car (cdr rest))) default))
|
||
(else (loop (cdr rest))))))
|
||
|
||
(define *daemons* '()) ; alist (op-name . (stdin-port . stdout-port))
|
||
|
||
;;; -- daemon pool (per-tier stubs marked) -----------------------
|
||
;;;
|
||
;;; spawn-process-stdio returns (stdin-port . stdout-port) for a
|
||
;;; long-running subprocess. Implementation varies by tier:
|
||
;;; Python: subprocess.Popen with stdin/stdout=PIPE
|
||
;;; C: fork + pipe + exec + dup2
|
||
;;; asm: syscall fork + pipe + execve
|
||
;;;
|
||
;;; lumbda's fleet doesn't have it today; the first place it's
|
||
;;; needed is here. Should land in each tier's primitive table
|
||
;;; alongside `tcp-*`.
|
||
|
||
;; start-daemon optionally takes extra-args (a list of strings) appended
|
||
;; after "--daemon" in the spawn argv. Day-4: secp256k1 daemon flips to
|
||
;; pass '("--window-w" "4") because v3 (Day-3 windowed-G ladder) clean-
|
||
;; wins at n>=100k vs v1; see plans/form-A-day4-progress.md.
|
||
(define (start-daemon binary-path . extra-args)
|
||
(let* ((argv (cons "--daemon"
|
||
(if (null? extra-args) '() (car extra-args))))
|
||
(pair (spawn-process-stdio binary-path argv))
|
||
(ready (read-line (cdr pair))))
|
||
(if (string=? ready "ready")
|
||
pair
|
||
(error "daemon failed to ready:" ready))))
|
||
|
||
;; Send `process[-bin] in out` to daemon, await `done` or `error`.
|
||
|
||
(define (daemon-process daemon-pair in-portal out-portal use-bin?)
|
||
(let ((cmd (if use-bin? "process-bin " "process ")))
|
||
(display cmd (car daemon-pair))
|
||
(display in-portal (car daemon-pair))
|
||
(display " " (car daemon-pair))
|
||
(display out-portal (car daemon-pair))
|
||
(newline (car daemon-pair))
|
||
(flush-port (car daemon-pair))
|
||
(let ((line (read-line (cdr daemon-pair))))
|
||
(cond
|
||
((eq? line #f) (cons 'error "daemon closed"))
|
||
((>= (string-length line) 5)
|
||
(cond
|
||
((string=? (substring line 0 4) "done") 'ok)
|
||
((string=? (substring line 0 5) "error") (cons 'error line))
|
||
(else (cons 'error (string-append "?: " line)))))
|
||
(else (cons 'error (string-append "?: " line)))))))
|
||
|
||
(define (register-daemon! op-name binary-path . extra-args)
|
||
(let ((pair (if (null? extra-args)
|
||
(start-daemon binary-path)
|
||
(start-daemon binary-path (car extra-args)))))
|
||
(set! *daemons*
|
||
(cons (cons op-name pair) *daemons*)))
|
||
(display "gpu-worker: ready ") (display op-name)
|
||
(display " <- ") (display binary-path)
|
||
(cond
|
||
((not (null? extra-args))
|
||
(display " extra-args=") (display (car extra-args))))
|
||
(newline))
|
||
|
||
;;; -- op handler -- cuda-shake-fanout ----------------------------
|
||
|
||
(define (gensym-path prefix suffix)
|
||
;; Each tier already has current-time-ms or gensym; if neither is
|
||
;; present, fall back to a counter. Simple uniqueness only.
|
||
(string-append prefix "-" (number->string (current-time-ms)) suffix))
|
||
|
||
(define (write-shake-input-portal! path inputs out-bytes)
|
||
(let ((port (open-output-file path)))
|
||
(display "(cuda-shake-fanout\n" port)
|
||
(display " (output-bytes " port) (display out-bytes port) (display ")\n" port)
|
||
(display " (inputs\n" port)
|
||
(for-each (lambda (h)
|
||
(display " \"" port) (display h port) (display "\"\n" port))
|
||
inputs)
|
||
(display "))\n" port)
|
||
(close-port port)))
|
||
|
||
(define (read-shake-output-portal path)
|
||
(let ((sexp (read-from-string (file->string path))))
|
||
(let loop ((children (cdr sexp)))
|
||
(cond
|
||
((null? children) '())
|
||
((and (pair? (car children)) (eq? (car (car children)) 'hashes))
|
||
(cdr (car children)))
|
||
(else (loop (cdr children)))))))
|
||
|
||
;; If x looks like (quote (...)) -- bend's serialized form -- return
|
||
|
||
;; the inner list. Otherwise return x unchanged.
|
||
|
||
(define (unquote-list x)
|
||
(cond
|
||
((and (pair? x) (eq? (car x) 'quote) (pair? (cdr x)))
|
||
(car (cdr x)))
|
||
(else x)))
|
||
|
||
;; daemon-or-error op-name → daemon-pair on success, or (error
|
||
;; (daemon-not-registered <op>)) S-exp on failure. Used by every
|
||
;; handle-cuda-* so a worker host that lacks a particular binary
|
||
;; returns a clean structured error instead of crashing the child
|
||
;; on (cdr #f). Callers branch on (pair? result) → real daemon vs
|
||
;; (eq? (car result) 'error) → propagate the error S-exp upstream.
|
||
(define (daemon-or-error op-name)
|
||
(let ((d (assoc op-name *daemons*)))
|
||
(cond
|
||
((eq? d #f) (list 'error (list 'daemon-not-registered op-name)))
|
||
(else (cdr d)))))
|
||
|
||
;; with-required-daemon — guards a binary-wire handler against missing
|
||
;; daemons. If the named daemon is registered, calls (body daemon-pair).
|
||
;; If not, sends "BERRdaemon-not-registered: <op>" over the binary wire
|
||
;; so the caller gets a clean error frame instead of an empty/closed
|
||
;; connection from a crashed child.
|
||
(define (with-required-daemon client op-name body)
|
||
(let ((d (assoc op-name *daemons*)))
|
||
(cond
|
||
((eq? d #f)
|
||
(wire-send-raw client
|
||
(string-append "BERRdaemon-not-registered: "
|
||
(symbol->string op-name))))
|
||
(else (body (cdr d))))))
|
||
|
||
(define (handle-cuda-shake-fanout args)
|
||
(let ((d (daemon-or-error 'cuda-shake-fanout)))
|
||
(cond
|
||
((and (pair? d) (eq? (car d) 'error)) d)
|
||
(else
|
||
(let* ((inputs (unquote-list (car args)))
|
||
(out-bytes (car (cdr args)))
|
||
(in-path (gensym-path "/tmp/bend-in" ".portal"))
|
||
(out-path (gensym-path "/tmp/bend-out" ".portal")))
|
||
(write-shake-input-portal! in-path inputs out-bytes)
|
||
(let ((status (daemon-process d in-path out-path #f)))
|
||
(cond
|
||
((eq? status 'ok)
|
||
(let ((result (read-shake-output-portal out-path)))
|
||
(delete-file in-path)
|
||
(delete-file out-path)
|
||
(list 'ok result)))
|
||
(else
|
||
(delete-file in-path) (delete-file out-path)
|
||
(list 'error (cdr status))))))))))
|
||
|
||
;;; -- op handler -- cuda-sim-ops-bin -----------------------------
|
||
;;;
|
||
;;; Request: (cuda-sim-ops-bin <ops-bin-path> <n-batches>)
|
||
;;; Spawns bend-cuda <path> <n-batches> --portal <tmp>, drains its
|
||
;;; stdout to EOF (process exit), reads the portal, returns the
|
||
;;; parsed (cuda-sim-result ...) form unchanged so callers can pull
|
||
;;; out gates / phase / timings.
|
||
|
||
(define (drain-to-eof port)
|
||
;; Read until read-line returns #f (or eof-object). Discard lines.
|
||
(let loop ()
|
||
(let ((line (read-line port)))
|
||
(cond
|
||
((eq? line #f) #t)
|
||
((eof-object? line) #t)
|
||
(else (loop))))))
|
||
|
||
;; Pull a numeric value out of a parsed portal expression for telemetry.
|
||
;; Walks (a b c ...) looking for (name <number>); returns #f if missing.
|
||
(define (portal-find-number form name)
|
||
;; Guard: form may arrive as #f when read-from-string sees an empty
|
||
;; or malformed portal file (bend-cuda crashed mid-write, OOM, etc).
|
||
;; A bare (cdr #f) here historically crashed the gpu-worker with
|
||
;; "error: not a pair: #f", taking the port-8320 listener down.
|
||
(cond
|
||
((not (pair? form)) #f)
|
||
(else
|
||
(let loop ((rest (cdr form)))
|
||
(cond
|
||
((null? rest) #f)
|
||
((not (pair? rest)) #f)
|
||
((and (pair? (car rest)) (eq? (car (car rest)) name)
|
||
(pair? (cdr (car rest))) (number? (car (cdr (car rest)))))
|
||
(car (cdr (car rest))))
|
||
(else (loop (cdr rest))))))))
|
||
|
||
;; Walk through (timing-ms (cpu-total X) (gpu-kernel Y)) shape.
|
||
(define (portal-timing form which)
|
||
(cond
|
||
((not (pair? form)) #f)
|
||
(else
|
||
(let loop ((rest (cdr form)))
|
||
(cond
|
||
((null? rest) #f)
|
||
((not (pair? rest)) #f)
|
||
((and (pair? (car rest)) (eq? (car (car rest)) 'timing-ms))
|
||
(portal-find-number (car rest) which))
|
||
(else (loop (cdr rest))))))))
|
||
|
||
(define (handle-cuda-sim-ops-bin args)
|
||
(let* ((ops-path (car args))
|
||
(n-batches (car (cdr args)))
|
||
(portal-path (gensym-path "/tmp/bend-sim-ops" ".portal"))
|
||
(t-start (current-time-ms)))
|
||
(cond
|
||
((not (file-exists? *binary-bend-cuda*))
|
||
(list 'error (list 'bend-cuda-binary-missing *binary-bend-cuda*)))
|
||
((not (file-exists? ops-path))
|
||
(display ";;; bend ERROR cuda-sim-ops-bin ops-bin-missing ")
|
||
(display ops-path) (newline)
|
||
(list 'error (list 'ops-bin-missing ops-path)))
|
||
(else
|
||
(display ";;; bend RECV cuda-sim-ops-bin ops=")
|
||
(display ops-path)
|
||
(display " n-batches=") (display n-batches)
|
||
(display " t-ms=") (display t-start) (newline)
|
||
(let* ((argv (list ops-path
|
||
(number->string n-batches)
|
||
"--portal" portal-path))
|
||
(pair (spawn-process-stdio *binary-bend-cuda* argv)))
|
||
;; bend-cuda does not read stdin; drain stdout until exit.
|
||
(drain-to-eof (cdr pair))
|
||
(close-port (car pair))
|
||
(close-port (cdr pair))
|
||
(let ((wall-ms (- (current-time-ms) t-start)))
|
||
(cond
|
||
((file-exists? portal-path)
|
||
(let* ((result (read-from-string (file->string portal-path)))
|
||
(cpu-ms (portal-timing result 'cpu-total))
|
||
(gpu-ms (portal-timing result 'gpu-kernel))
|
||
(mismatches (portal-find-number result 'mismatches)))
|
||
(delete-file portal-path)
|
||
(display ";;; bend DONE cuda-sim-ops-bin")
|
||
(display " n-batches=") (display n-batches)
|
||
(display " wall-ms=") (display wall-ms)
|
||
(display " cpu-ms=") (display (or cpu-ms 'NA))
|
||
(display " gpu-ms=") (display (or gpu-ms 'NA))
|
||
(display " mismatches=") (display (or mismatches 'NA))
|
||
(cond
|
||
((and (number? cpu-ms) (number? gpu-ms) (> gpu-ms 0))
|
||
(display " gpu/cpu=")
|
||
(display (/ cpu-ms gpu-ms))))
|
||
(newline)
|
||
(list 'ok result)))
|
||
(else
|
||
(display ";;; bend FAIL cuda-sim-ops-bin no-portal wall-ms=")
|
||
(display wall-ms) (newline)
|
||
(list 'error (list 'no-portal portal-path))))))))))
|
||
|
||
;;; -- op handler -- cuda-secp256k1-bench --------------------------
|
||
;;;
|
||
;;; (cuda-secp256k1-bench N) — batched scalar*G on N random scalars.
|
||
;;;
|
||
;;; This is the "feel the GPU win" demo handler. HTTP callers can't
|
||
;;; ship a 32*N-byte BSCP payload over the playground bend bridge
|
||
;;; for any meaningful N, so the worker generates the input file
|
||
;;; itself from os.urandom via examples/cuda-fanout/generate-bscp.py,
|
||
;;; dispatches to the existing secp256k1-batched-mul daemon (same
|
||
;;; one the BSCP wire mode hits), and returns timing data — not the
|
||
;;; N*64-byte output, which would balloon the response.
|
||
;;;
|
||
;;; Returns (ok (n N) (gen-ms G) (gpu-ms D) (gpu-mkeys-per-sec R)
|
||
;;; (cpu-rate-mkeys-per-sec C) (cpu-est-sec E)
|
||
;;; (speedup-est S) (sample-x HEX))
|
||
;;;
|
||
;;; cpu-rate-mkeys-per-sec is the libsecp256k1 single-thread reference
|
||
;;; (~0.05 Mkeys/s = 50K scalar*G/sec on a modern x86 core); used to
|
||
;;; extrapolate the CPU time without actually running it.
|
||
(define *bscp-generator-path*
|
||
(string-append (or (get-environment-variable "PWD") ".")
|
||
"/generate-bscp.py"))
|
||
(define *cpu-secp256k1-rate-mkeys-per-sec* 0.05) ; libsecp256k1 single-thread ref
|
||
|
||
(define (generate-bscp-file count out-path)
|
||
;; Spawn generate-bscp.py COUNT OUT_PATH, drain stdout to EOF.
|
||
;; Returns 'ok on success, (error <reason>) on failure.
|
||
(cond
|
||
((not (file-exists? "/usr/bin/python3"))
|
||
(list 'error 'python3-missing))
|
||
((not (file-exists? *bscp-generator-path*))
|
||
(list 'error (list 'generator-script-missing *bscp-generator-path*)))
|
||
(else
|
||
(let ((pair (spawn-process-stdio
|
||
"/usr/bin/python3"
|
||
(list *bscp-generator-path*
|
||
(number->string count)
|
||
out-path))))
|
||
(cond
|
||
((eq? pair #f) (list 'error 'spawn-failed))
|
||
(else
|
||
(close-port (car pair))
|
||
(drain-to-eof (cdr pair))
|
||
(close-port (cdr pair))
|
||
(cond
|
||
((file-exists? out-path) 'ok)
|
||
(else (list 'error 'no-output)))))))))
|
||
|
||
(define (handle-cuda-secp256k1-bench args)
|
||
(let ((d (daemon-or-error 'cuda-secp256k1-batched-mul)))
|
||
(cond
|
||
((and (pair? d) (eq? (car d) 'error)) d)
|
||
(else
|
||
(let* ((daemon d)
|
||
(count (car args))
|
||
(in-path (gensym-path "/tmp/bend-secp-bench-in" ".bscp"))
|
||
(out-path (gensym-path "/tmp/bend-secp-bench-out" ".bscr"))
|
||
(t-gen-start (current-time-ms))
|
||
(gen-status (generate-bscp-file count in-path))
|
||
(gen-ms (- (current-time-ms) t-gen-start)))
|
||
(cond
|
||
((not (eq? gen-status 'ok))
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(list 'error (list 'bscp-generate-failed gen-status)))
|
||
(else
|
||
(display ";;; bend RECV cuda-secp256k1-bench n=")
|
||
(display count)
|
||
(display " gen-ms=") (display gen-ms) (newline)
|
||
(let* ((t-gpu-start (current-time-ms))
|
||
(status (daemon-process daemon in-path out-path #t))
|
||
(gpu-ms (- (current-time-ms) t-gpu-start)))
|
||
(cond
|
||
((not (eq? status 'ok))
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(list 'error (list 'daemon-failed (cdr status))))
|
||
(else
|
||
(let* ((gpu-sec (/ gpu-ms 1000.0))
|
||
(gpu-rate (cond ((> gpu-sec 0) (/ count gpu-sec 1000000.0))
|
||
(else 0)))
|
||
(cpu-rate *cpu-secp256k1-rate-mkeys-per-sec*)
|
||
(cpu-est-sec (cond ((> cpu-rate 0)
|
||
(/ count cpu-rate 1000000.0))
|
||
(else 0)))
|
||
(cpu-est-min (/ cpu-est-sec 60.0))
|
||
(speedup (cond ((> gpu-rate 0) (/ gpu-rate cpu-rate))
|
||
(else 0)))
|
||
(summary
|
||
(string-append
|
||
"✦ GPU just batched " (with-commas count)
|
||
" secp256k1 public-key computations.\n"
|
||
"\n"
|
||
" scalar gen : " (number->string gen-ms) " ms (random.urandom)\n"
|
||
" GPU kernel : " (number->string gpu-ms) " ms (RTX 3090, --window-w 4)\n"
|
||
" GPU throughput : " (format-float gpu-rate 2) " million keys / second\n"
|
||
"\n"
|
||
" CPU baseline ref: " (format-float cpu-rate 3)
|
||
" Mkeys/s (libsecp256k1 single core)\n"
|
||
" CPU would need : " (format-float cpu-est-min 1) " minutes ("
|
||
(format-float cpu-est-sec 0) " sec)\n"
|
||
" GPU finished in : " (format-float gpu-sec 1) " sec\n"
|
||
" speedup : ~" (format-float speedup 0) "× faster on GPU")))
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(display ";;; bend DONE cuda-secp256k1-bench n=")
|
||
(display count)
|
||
(display " gpu-ms=") (display gpu-ms)
|
||
(display " mkeys-s=") (display gpu-rate) (newline)
|
||
;; Return the formatted summary string directly
|
||
;; (caught by http-listener's string? guard, sent
|
||
;; raw — no S-exp escape soup in the playground
|
||
;; output). The structured fields all live inside
|
||
;; the human text.
|
||
summary)))))))))))
|
||
|
||
;; Format a non-negative integer with thousand-separator commas.
|
||
;; (with-commas 100000000) → "100,000,000".
|
||
(define (with-commas n)
|
||
(let ((s (number->string n)))
|
||
(cond
|
||
((< (string-length s) 4) s)
|
||
(else
|
||
(let ((head-len (- (string-length s) 3)))
|
||
(string-append
|
||
(with-commas (string->number (substring s 0 head-len)))
|
||
","
|
||
(substring s head-len (string-length s))))))))
|
||
|
||
;; Truncate a number's string form to at most n decimal places. Lumbda's
|
||
;; rational division of two ints returns an exact rational ("7/3") which
|
||
;; doesn't survive truncation, so we coerce to float first by adding 0.0
|
||
;; before taking number->string. n=0 drops the decimal point too.
|
||
(define (format-float x n)
|
||
(let ((s (number->string (+ x 0.0))))
|
||
(let loop ((i 0))
|
||
(cond
|
||
((>= i (string-length s)) s)
|
||
((char=? (string-ref s i) #\.)
|
||
(cond
|
||
((= n 0) (substring s 0 i))
|
||
(else
|
||
(let ((cap (+ i 1 n)))
|
||
(cond
|
||
((>= cap (string-length s)) s)
|
||
(else (substring s 0 cap)))))))
|
||
(else (loop (+ i 1)))))))
|
||
|
||
;;; -- op handler -- health --------------------------------------
|
||
;;;
|
||
;;; (health) returns
|
||
;;; (ok (load-avg L) (vram-free-mb V) (uptime-ms U))
|
||
;;;
|
||
;;; L = 1-minute load average parsed from /proc/loadavg
|
||
;;; V = MB of free VRAM from `nvidia-smi --query-gpu=memory.free`
|
||
;;; U = current-time-ms (millisecond wallclock, lets a client detect
|
||
;;; a worker that hung & restarted between probes)
|
||
;;;
|
||
;;; Cheap (sub-millisecond load-avg + a single nvidia-smi exec for
|
||
;;; VRAM). Cache TTL on a client makes per-dispatch polling free.
|
||
|
||
(define (parse-leading-number s)
|
||
;; Longest digit-or-decimal-point run from index 0; 0 on failure.
|
||
(let* ((n (string-length s))
|
||
(end (let scan ((i 0))
|
||
(cond
|
||
((>= i n) i)
|
||
((let ((c (string-ref s i)))
|
||
(or (char-numeric? c) (char=? c #\.)))
|
||
(scan (+ i 1)))
|
||
(else i)))))
|
||
(cond
|
||
((= end 0) 0)
|
||
(else (or (string->number (substring s 0 end)) 0)))))
|
||
|
||
(define (health-load-avg)
|
||
(let ((s (file->string "/proc/loadavg")))
|
||
(cond
|
||
((eq? s #f) 0)
|
||
(else (parse-leading-number s)))))
|
||
|
||
(define (health-vram-free-mb)
|
||
;; nvidia-smi --query-gpu=memory.free --format=csv,noheader,nounits
|
||
;; one number per GPU, one per line; first line suffices.
|
||
;; Returns 0 when nvidia-smi missing (host without an NVIDIA GPU)
|
||
;; or when the spawn output cannot be parsed — never raises.
|
||
(cond
|
||
((not (file-exists? "/usr/bin/nvidia-smi")) 0)
|
||
(else
|
||
(let ((pair (spawn-process-stdio "/usr/bin/nvidia-smi"
|
||
'("--query-gpu=memory.free"
|
||
"--format=csv,noheader,nounits"))))
|
||
(cond
|
||
((eq? pair #f) 0)
|
||
(else
|
||
(let ((line (read-line (cdr pair))))
|
||
(close-port (car pair))
|
||
(close-port (cdr pair))
|
||
(cond
|
||
((eq? line #f) 0)
|
||
((eof-object? line) 0)
|
||
(else (parse-leading-number line))))))))))
|
||
|
||
;;; -- pool / queue health -------------------------------------------
|
||
;;;
|
||
;;; bend co-lives with an bend-emit-pool on each foxhop production host.
|
||
;;; When the pool dies but bend stays up, .lsp cells pile up un-emitted
|
||
;;; and bend sits idle waiting for .ready bins that never arrive. The
|
||
;;; feeder daemon polls bend's (health) to know whether to push more
|
||
;;; work — adding pool/queue counts here means a single RPC tells the
|
||
;;; feeder everything: bend health, pool health, queue depth.
|
||
;;;
|
||
;;; BEND_QUEUE_DIR env var — set when bend is launched on a host with
|
||
;;; an associated pool. Absent on hosts that only run bend without a
|
||
;;; pool. When absent, queue counts return -1 (caller treats as
|
||
;;; "unknown / not applicable").
|
||
|
||
(define (run-and-count cmd-args)
|
||
;; Spawn cmd-args, read all stdout lines, return integer line count.
|
||
;; Returns 0 on spawn failure. Used to count ls / pgrep output.
|
||
(cond
|
||
((not (file-exists? (car cmd-args))) 0)
|
||
(else
|
||
(let ((pair (spawn-process-stdio (car cmd-args) (cdr cmd-args))))
|
||
(cond
|
||
((eq? pair #f) 0)
|
||
(else
|
||
(let loop ((count 0))
|
||
(let ((line (read-line (cdr pair))))
|
||
(cond
|
||
((or (eq? line #f) (eof-object? line))
|
||
(close-port (car pair))
|
||
(close-port (cdr pair))
|
||
count)
|
||
(else (loop (+ count 1))))))))))))
|
||
|
||
(define (health-pool-procs)
|
||
;; Count of bend-emit-pool processes on this host. 0 = pool dead.
|
||
(let* ((pair (spawn-process-stdio "/usr/bin/pgrep"
|
||
'("-cf" "bend-emit-pool"))))
|
||
(cond
|
||
((eq? pair #f) 0)
|
||
(else
|
||
(let ((line (read-line (cdr pair))))
|
||
(close-port (car pair))
|
||
(close-port (cdr pair))
|
||
(cond
|
||
((or (eq? line #f) (eof-object? line)) 0)
|
||
(else (or (string->number (parse-trim line)) 0))))))))
|
||
|
||
(define (health-dispatcher-procs)
|
||
;; Count of bend-dispatcher processes on this host. <=1 = dispatcher
|
||
;; functionally dead (only stale wrapper bash matched). Live
|
||
;; multi-dispatcher = parent + 2 worker forks = ≥3 procs.
|
||
(let* ((pair (spawn-process-stdio "/usr/bin/pgrep"
|
||
'("-cf" "bend-dispatcher"))))
|
||
(cond
|
||
((eq? pair #f) 0)
|
||
(else
|
||
(let ((line (read-line (cdr pair))))
|
||
(close-port (car pair))
|
||
(close-port (cdr pair))
|
||
(cond
|
||
((or (eq? line #f) (eof-object? line)) 0)
|
||
(else (or (string->number (parse-trim line)) 0))))))))
|
||
|
||
(define (parse-trim s)
|
||
;; Strip leading/trailing whitespace from a single-line string.
|
||
(let* ((n (string-length s))
|
||
(lo (let ll ((i 0))
|
||
(cond
|
||
((>= i n) i)
|
||
((char-whitespace? (string-ref s i)) (ll (+ i 1)))
|
||
(else i))))
|
||
(hi (let lh ((i (- n 1)))
|
||
(cond
|
||
((< i lo) lo)
|
||
((char-whitespace? (string-ref s i)) (lh (- i 1)))
|
||
(else (+ i 1))))))
|
||
(substring s lo hi)))
|
||
|
||
(define (health-queue-count ext)
|
||
;; Count of files matching $BEND_QUEUE_DIR/*.<ext>. Returns -1 when
|
||
;; BEND_QUEUE_DIR env is unset (caller treats as unknown).
|
||
(let ((qdir (get-environment-variable "BEND_QUEUE_DIR")))
|
||
(cond
|
||
((or (eq? qdir #f) (string=? qdir "")) -1)
|
||
(else
|
||
(let* ((pattern (string-append qdir "/*." ext))
|
||
(pair (spawn-process-stdio "/bin/sh"
|
||
(list "-c"
|
||
(string-append "ls " pattern " 2>/dev/null | wc -l")))))
|
||
(cond
|
||
((eq? pair #f) 0)
|
||
(else
|
||
(let ((line (read-line (cdr pair))))
|
||
(close-port (car pair))
|
||
(close-port (cdr pair))
|
||
(cond
|
||
((or (eq? line #f) (eof-object? line)) 0)
|
||
(else (or (string->number (parse-trim line)) 0)))))))))))
|
||
|
||
(define (health-feeder-paused)
|
||
;; 1 if $BEND_QUEUE_DIR/FEEDER_PAUSE marker present (operator wants
|
||
;; this host out of the rotation; feeder should not push or restart
|
||
;; supervisors here). 0 if no marker. -1 if BEND_QUEUE_DIR unset.
|
||
(let ((qdir (get-environment-variable "BEND_QUEUE_DIR")))
|
||
(cond
|
||
((or (eq? qdir #f) (string=? qdir "")) -1)
|
||
((file-exists? (string-append qdir "/FEEDER_PAUSE")) 1)
|
||
(else 0))))
|
||
|
||
(define (handle-health)
|
||
(list 'ok
|
||
(list 'load-avg (health-load-avg))
|
||
(list 'vram-free-mb (health-vram-free-mb))
|
||
(list 'uptime-ms (current-time-ms))
|
||
(list 'pool-procs (health-pool-procs))
|
||
(list 'dispatcher-procs (health-dispatcher-procs))
|
||
(list 'queue-ready (health-queue-count "ready"))
|
||
(list 'queue-emitting (health-queue-count "emitting"))
|
||
(list 'queue-done (health-queue-count "done"))
|
||
(list 'feeder-paused (health-feeder-paused))))
|
||
|
||
;;; -- dispatch --------------------------------------------------
|
||
|
||
(define (handle-request sexp)
|
||
(cond
|
||
((not (pair? sexp)) (list 'error "not a form"))
|
||
(else
|
||
(let ((op (car sexp)) (args (cdr sexp)))
|
||
(cond
|
||
((eq? op 'cuda-shake-fanout) (handle-cuda-shake-fanout args))
|
||
((eq? op 'cuda-sim-ops-bin) (handle-cuda-sim-ops-bin args))
|
||
((eq? op 'cuda-secp256k1-bench) (handle-cuda-secp256k1-bench args))
|
||
((eq? op 'health) (handle-health))
|
||
((eq? op 'ping) (list 'ok 'pong))
|
||
(else (list 'error (list 'unknown-op op))))))))
|
||
|
||
;; Binary wire mode: payload starts with magic "BSHK" then a
|
||
;; daemon-binary-portal blob (u32 out_bytes | u32 n | n x (u32 len + bytes)).
|
||
;; Worker writes the blob to disk, calls daemon process-bin, reads the
|
||
;; binary result, prepends "BSHR" magic, wire-send-raws it back.
|
||
|
||
(define (handle-binary-shake client payload)
|
||
(let ((d (daemon-or-error 'cuda-shake-fanout)))
|
||
(cond
|
||
((and (pair? d) (eq? (car d) 'error))
|
||
(wire-send-raw client "BERRdaemon-not-registered: cuda-shake-fanout"))
|
||
(else
|
||
(let* ((daemon d)
|
||
(in-path (gensym-path "/tmp/bend-bin-in" ".bin"))
|
||
(out-path (gensym-path "/tmp/bend-bin-out" ".bin"))
|
||
(portal-blob (substring payload 4 (string-length payload))))
|
||
(write-binary-file in-path portal-blob)
|
||
(let ((status (daemon-process daemon in-path out-path #t)))
|
||
(cond
|
||
((eq? status 'ok)
|
||
(let ((result-blob (read-binary-file out-path)))
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(wire-send-raw client (string-append "BSHR" result-blob))))
|
||
(else
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(wire-send-raw client (string-append "BERR" (cdr status)))))))))))
|
||
|
||
;; Binary wire for bend form B (cuda-bignum-cgbn).
|
||
;; Payload begins with "BCGB"; pass entire blob through to the daemon,
|
||
;; which expects the same magic + header it received from the client.
|
||
(define (handle-binary-cgbn client payload)
|
||
(with-required-daemon client 'cuda-bignum-cgbn (lambda (daemon)
|
||
(let* ((in-path (gensym-path "/tmp/bend-cgbn-in" ".bin"))
|
||
(out-path (gensym-path "/tmp/bend-cgbn-out" ".bin"))
|
||
(t-start (current-time-ms)))
|
||
(write-binary-file in-path payload)
|
||
(display ";;; bend RECV cuda-bignum-cgbn bytes=")
|
||
(display (string-length payload))
|
||
(display " t-ms=") (display t-start) (newline)
|
||
(let ((status (daemon-process daemon in-path out-path #t)))
|
||
(let ((wall-ms (- (current-time-ms) t-start)))
|
||
(cond
|
||
((eq? status 'ok)
|
||
(let ((result-blob (read-binary-file out-path)))
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(display ";;; bend DONE cuda-bignum-cgbn")
|
||
(display " wall-ms=") (display wall-ms)
|
||
(display " out-bytes=") (display (string-length result-blob))
|
||
(newline)
|
||
(wire-send-raw client result-blob)))
|
||
(else
|
||
(display ";;; bend FAIL cuda-bignum-cgbn wall-ms=")
|
||
(display wall-ms) (newline)
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(wire-send-raw client (string-append "BERR" (cdr status)))))))))))
|
||
|
||
;; Binary wire for bend form A (cuda-secp256k1-batched-mul).
|
||
;; Payload begins with "BSCP"; pass entire blob through to the daemon,
|
||
;; which expects the same magic + header. Response payload begins
|
||
;; with "BSCR" on success or "BERR" on failure.
|
||
(define (handle-binary-secp client payload)
|
||
(with-required-daemon client 'cuda-secp256k1-batched-mul (lambda (daemon)
|
||
(let* ((in-path (gensym-path "/tmp/bend-secp-in" ".bin"))
|
||
(out-path (gensym-path "/tmp/bend-secp-out" ".bin"))
|
||
(t-start (current-time-ms)))
|
||
(write-binary-file in-path payload)
|
||
(display ";;; bend RECV cuda-secp256k1-batched-mul bytes=")
|
||
(display (string-length payload))
|
||
(display " t-ms=") (display t-start) (newline)
|
||
(let ((status (daemon-process daemon in-path out-path #t)))
|
||
(let ((wall-ms (- (current-time-ms) t-start)))
|
||
(cond
|
||
((eq? status 'ok)
|
||
(let ((result-blob (read-binary-file out-path)))
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(display ";;; bend DONE cuda-secp256k1-batched-mul")
|
||
(display " wall-ms=") (display wall-ms)
|
||
(display " out-bytes=") (display (string-length result-blob))
|
||
(newline)
|
||
(wire-send-raw client result-blob)))
|
||
(else
|
||
(display ";;; bend FAIL cuda-secp256k1-batched-mul wall-ms=")
|
||
(display wall-ms) (newline)
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(wire-send-raw client (string-append "BERR" (cdr status)))))))))))
|
||
|
||
;; Binary wire for Wave-2 form `cuda-blake3-tree` (BLAKE3 batched fan-out).
|
||
;; Payload begins with "BSB3". The .cu daemon (blake3-fanout.cu) expects
|
||
;; the same magic + header in its on-disk binary file (matches the BCGB /
|
||
;; BSCP / BSRT pattern, not the BSHK strip-magic pattern), so we pass the
|
||
;; entire payload through verbatim. The daemon's response file already
|
||
;; begins with "BSR3"; pass through unchanged.
|
||
(define (handle-binary-blake3 client payload)
|
||
(with-required-daemon client 'cuda-blake3-tree (lambda (daemon)
|
||
(let* ((in-path (gensym-path "/tmp/bend-blake3-in" ".bin"))
|
||
(out-path (gensym-path "/tmp/bend-blake3-out" ".bin"))
|
||
(t-start (current-time-ms)))
|
||
(write-binary-file in-path payload)
|
||
(display ";;; bend RECV cuda-blake3-tree bytes=")
|
||
(display (string-length payload))
|
||
(display " t-ms=") (display t-start) (newline)
|
||
(let ((status (daemon-process daemon in-path out-path #t)))
|
||
(let ((wall-ms (- (current-time-ms) t-start)))
|
||
(cond
|
||
((eq? status 'ok)
|
||
(let ((result-blob (read-binary-file out-path)))
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(display ";;; bend DONE cuda-blake3-tree")
|
||
(display " wall-ms=") (display wall-ms)
|
||
(display " out-bytes=") (display (string-length result-blob))
|
||
(newline)
|
||
(wire-send-raw client result-blob)))
|
||
(else
|
||
(display ";;; bend FAIL cuda-blake3-tree wall-ms=")
|
||
(display wall-ms) (newline)
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(wire-send-raw client (string-append "BERR" (cdr status)))))))))))
|
||
|
||
;; Binary wire for bend form G (cuda-radix-sort).
|
||
;; Payload begins with "BSRT"; pass entire blob through to the daemon,
|
||
;; which expects the same magic + header. Response begins with "BSRR"
|
||
;; on success or "BERR" on failure.
|
||
(define (handle-binary-sort client payload)
|
||
(with-required-daemon client 'cuda-radix-sort (lambda (daemon)
|
||
(let* ((in-path (gensym-path "/tmp/bend-sort-in" ".bin"))
|
||
(out-path (gensym-path "/tmp/bend-sort-out" ".bin"))
|
||
(t-start (current-time-ms)))
|
||
(write-binary-file in-path payload)
|
||
(display ";;; bend RECV cuda-radix-sort bytes=")
|
||
(display (string-length payload))
|
||
(display " t-ms=") (display t-start) (newline)
|
||
(let ((status (daemon-process daemon in-path out-path #t)))
|
||
(let ((wall-ms (- (current-time-ms) t-start)))
|
||
(cond
|
||
((eq? status 'ok)
|
||
(let ((result-blob (read-binary-file out-path)))
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(display ";;; bend DONE cuda-radix-sort")
|
||
(display " wall-ms=") (display wall-ms)
|
||
(display " out-bytes=") (display (string-length result-blob))
|
||
(newline)
|
||
(wire-send-raw client result-blob)))
|
||
(else
|
||
(display ";;; bend FAIL cuda-radix-sort wall-ms=")
|
||
(display wall-ms) (newline)
|
||
(if (file-exists? in-path) (delete-file in-path))
|
||
(if (file-exists? out-path) (delete-file out-path))
|
||
(wire-send-raw client (string-append "BERR" (cdr status)))))))))))
|
||
|
||
;; Accept one client, handle one request, close. Returns #t to keep
|
||
;; serving, #f when the server should stop.
|
||
(define (handle-one server)
|
||
(let ((client (tcp-accept server)))
|
||
(cond
|
||
((eq? client #f) #t)
|
||
(else
|
||
(let ((payload (wire-recv-raw client)))
|
||
(cond
|
||
((eq? payload #f) (tcp-close client) #t)
|
||
((and (>= (string-length payload) 4)
|
||
(string=? (substring payload 0 4) "BSHK"))
|
||
(handle-binary-shake client payload)
|
||
(tcp-close client) #t)
|
||
((and (>= (string-length payload) 4)
|
||
(string=? (substring payload 0 4) "BCGB"))
|
||
(handle-binary-cgbn client payload)
|
||
(tcp-close client) #t)
|
||
((and (>= (string-length payload) 4)
|
||
(string=? (substring payload 0 4) "BSCP"))
|
||
(handle-binary-secp client payload)
|
||
(tcp-close client) #t)
|
||
((and (>= (string-length payload) 4)
|
||
(string=? (substring payload 0 4) "BSRT"))
|
||
(handle-binary-sort client payload)
|
||
(tcp-close client) #t)
|
||
((and (>= (string-length payload) 4)
|
||
(string=? (substring payload 0 4) "BSB3"))
|
||
(handle-binary-blake3 client payload)
|
||
(tcp-close client) #t)
|
||
(else
|
||
(let* ((req (read-from-string payload))
|
||
(resp (handle-request req)))
|
||
(wire-send client resp)
|
||
(tcp-close client)
|
||
#t))))))))
|
||
|
||
;;; -- VRAM-aware admission control ------------------------------
|
||
;;;
|
||
;;; bend-cuda holds ~bin-size GB of VRAM during its run (per
|
||
;;; foxhop empirical: bin file size on disk ≈ peak VRAM used by
|
||
;;; bend-cuda loading + running that bin).
|
||
;;;
|
||
;;; DYNAMIC algorithm: query running EMA per bend-form (op kind),
|
||
;;; combine with current nvidia-smi reading + projected new-cell
|
||
;;; cost. Fork iff (current_vram + projected_cell_vram + safety) < gpu_total.
|
||
;;; No static max-children cap — the algorithm picks N based on
|
||
;;; observed per-form VRAM usage. Larger cells = fewer concurrent;
|
||
;;; tiny cells = many concurrent. Self-tuning to each bend form.
|
||
|
||
(define *gpu-total-mib*
|
||
(let ((env (get-environment-variable "LUMBDA_GPU_TOTAL_MIB")))
|
||
(cond
|
||
((and env (> (string-length env) 0)) (string->number env))
|
||
(else 24576)))) ; 24 GB default (RTX 3090)
|
||
|
||
(define *gpu-headroom-mib*
|
||
(let ((env (get-environment-variable "LUMBDA_GPU_HEADROOM_MIB")))
|
||
(cond
|
||
((and env (> (string-length env) 0)) (string->number env))
|
||
(else 1024)))) ; 1 GB safety pad
|
||
|
||
;; Running max per-cell VRAM observed. Conservative — uses largest
|
||
;; bin seen, not average. Single-slot mutable. Initial 4096 MiB =
|
||
;; pessimistic seed until we observe real cells.
|
||
;; Seed lowered 4096→2500 (2026-06-11) — real K=2 bin avg is ~2.4GB.
|
||
;; Overprojection at 4096 throttled admit to 2-3 concurrent for big bins
|
||
;; even when 4-5 would fit; lower seed lets autoscaler use full GPU headroom.
|
||
;; record-cell-vram! in child still updates running max if larger seen.
|
||
(define *vram-per-cell-max-mib* 2500)
|
||
|
||
;; Fail-open on hosts without nvidia-smi (CPU-only users running their
|
||
;; own bend from a laptop). Python tier's spawn-process-stdio raises
|
||
;; FileNotFoundError on a missing binary instead of returning #f, which
|
||
;; would crash the worker; check file-exists? before the spawn.
|
||
(define (vram-used-mib)
|
||
;; nvidia-smi --query-gpu=memory.used --format=csv,noheader,nounits
|
||
;; returns one integer line per GPU; sum if multi-GPU host.
|
||
(cond
|
||
((not (file-exists? "/usr/bin/nvidia-smi")) 0)
|
||
(else
|
||
(let* ((pair (spawn-process-stdio
|
||
"/usr/bin/nvidia-smi"
|
||
'("--query-gpu=memory.used"
|
||
"--format=csv,noheader,nounits"))))
|
||
(cond
|
||
((eq? pair #f) 0) ;; fail-open: assume 0 if nvidia-smi missing
|
||
(else
|
||
(close-port (car pair)) ;; close stdin to child
|
||
(let loop ((sum 0))
|
||
(let ((line (read-line (cdr pair))))
|
||
(cond
|
||
((eof-object? line) (close-port (cdr pair)) sum)
|
||
(else
|
||
(let ((n (string->number (string-trim line))))
|
||
(loop (+ sum (cond (n n) (else 0)))))))))))))))
|
||
|
||
(define (string-trim s)
|
||
;; trim leading + trailing whitespace.
|
||
(let* ((len (string-length s))
|
||
(start (let loop ((i 0))
|
||
(cond ((>= i len) len)
|
||
((char-whitespace? (string-ref s i)) (loop (+ i 1)))
|
||
(else i))))
|
||
(end (let loop ((i (- len 1)))
|
||
(cond ((< i start) start)
|
||
((char-whitespace? (string-ref s i)) (loop (- i 1)))
|
||
(else (+ i 1))))))
|
||
(substring s start end)))
|
||
|
||
(define (file-size-mib path)
|
||
;; Stat a bin path; return its size in MiB. Returns 0 on missing
|
||
;; file (fail-open). Used as cheap proxy for per-cell VRAM cost
|
||
;; before forking — bin file on disk ≈ peak VRAM used by bend-cuda
|
||
;; loading + running that bin (per foxhop empirical).
|
||
(let* ((pair (spawn-process-stdio
|
||
"/usr/bin/stat" (list "-c" "%s" path))))
|
||
(cond
|
||
((eq? pair #f) 0)
|
||
(else
|
||
(close-port (car pair))
|
||
(let ((line (read-line (cdr pair))))
|
||
(close-port (cdr pair))
|
||
(cond
|
||
((or (eof-object? line) (not line)) 0)
|
||
(else
|
||
(let ((n (string->number (string-trim line))))
|
||
(cond ((not n) 0)
|
||
(else (quotient n 1048576))))))))))) ; bytes → MiB
|
||
|
||
(define (admit-fork? projected-cell-mib)
|
||
;; Dynamic admit decision: fork iff current VRAM + projected cell
|
||
;; + safety pad < total GPU memory. Self-tuning to per-cell sizes
|
||
;; observed (caller updates *vram-per-cell-max-mib* after each fork).
|
||
(let* ((used (vram-used-mib))
|
||
(need (+ used projected-cell-mib *gpu-headroom-mib*)))
|
||
(< need *gpu-total-mib*)))
|
||
|
||
(define (wait-admit projected-cell-mib)
|
||
;; Block until admission lets the next fork through. Reap zombies
|
||
;; while waiting so they don't pile up.
|
||
(let loop ()
|
||
(waitpid-nonblock)
|
||
(cond
|
||
((admit-fork? projected-cell-mib) #t)
|
||
(else (sleep 1) (loop)))))
|
||
|
||
(define (record-cell-vram! observed-mib)
|
||
;; Track max observed cell VRAM. Conservative — uses max not mean,
|
||
;; so admission stays safe under heterogeneous workloads.
|
||
(cond
|
||
((> observed-mib *vram-per-cell-max-mib*)
|
||
(set! *vram-per-cell-max-mib* observed-mib))))
|
||
|
||
;;; -- entry -----------------------------------------------------
|
||
|
||
;;; run-loop — fork-per-accept pattern.
|
||
;;;
|
||
;;; Accept connection → check VRAM budget → fork child handler →
|
||
;;; parent reaps zombies + returns to accept. Child runs handle-one
|
||
;;; (which spawns bend-cuda + waits + responds) then exits — its
|
||
;;; bend-cuda subprocess holds VRAM for the duration of that one
|
||
;;; request, naturally isolated from sibling children.
|
||
;;;
|
||
;;; This gives concurrent dispatch on a single PID without lumbda
|
||
;;; needing threading primitives. Linux COW handles parent->child
|
||
;;; memory; OS scheduler distributes across cores.
|
||
(define (run-loop server)
|
||
(waitpid-nonblock) ;; reap any completed child
|
||
(wait-admit *vram-per-cell-max-mib*) ;; dynamic: admit if room for largest seen cell
|
||
(let ((client (tcp-accept server)))
|
||
(cond
|
||
((eq? client #f) (run-loop server))
|
||
(else
|
||
(let ((pid (fork-self)))
|
||
(cond
|
||
((eq? pid #f)
|
||
;; fork failed — fall back to serial handle
|
||
(handle-one-client client server)
|
||
(run-loop server))
|
||
((eq? pid 0)
|
||
;; child: handle this one client, then exit
|
||
(handle-one-client client server)
|
||
(exit 0))
|
||
(else
|
||
;; parent: close our copy of client fd, loop to accept
|
||
(tcp-close client)
|
||
(run-loop server))))))))
|
||
|
||
;;; handle-one-client — same dispatch as the old handle-one body but
|
||
;;; takes the already-accepted client port as arg (no accept call).
|
||
;;;
|
||
;;; After reading the request, update *vram-per-cell-max-mib* with the
|
||
;;; bin file size as a proxy for per-cell VRAM. Self-tunes admission
|
||
;;; for subsequent forks. NOTE: this runs IN THE CHILD process; the
|
||
;;; parent's *vram-per-cell-max-mib* won't see it (forks don't share
|
||
;;; memory). For the algorithm to learn cross-fork, the parent needs
|
||
;;; to read the bin size pre-fork (TODO: peek request before forking,
|
||
;;; or have child write a small note for parent to read).
|
||
(define (handle-one-client client server)
|
||
(let ((payload (wire-recv-raw client)))
|
||
(cond
|
||
((eq? payload #f) (tcp-close client))
|
||
((and (>= (string-length payload) 4)
|
||
(string=? (substring payload 0 4) "BSHK"))
|
||
(handle-binary-shake client payload)
|
||
(tcp-close client))
|
||
((and (>= (string-length payload) 4)
|
||
(string=? (substring payload 0 4) "BCGB"))
|
||
(handle-binary-cgbn client payload)
|
||
(tcp-close client))
|
||
((and (>= (string-length payload) 4)
|
||
(string=? (substring payload 0 4) "BSCP"))
|
||
(handle-binary-secp client payload)
|
||
(tcp-close client))
|
||
((and (>= (string-length payload) 4)
|
||
(string=? (substring payload 0 4) "BSRT"))
|
||
(handle-binary-sort client payload)
|
||
(tcp-close client))
|
||
((and (>= (string-length payload) 4)
|
||
(string=? (substring payload 0 4) "BSB3"))
|
||
(handle-binary-blake3 client payload)
|
||
(tcp-close client))
|
||
(else
|
||
(let* ((req (read-from-string payload))
|
||
(resp (handle-request req)))
|
||
(wire-send client resp)
|
||
(tcp-close client))))))
|
||
|
||
;;; -- HTTP path -------------------------------------------------
|
||
;;;
|
||
;;; Mirrors the TCP path's fork-per-accept model so concurrent HTTP
|
||
;;; clients run isolated children with the same VRAM admission
|
||
;;; gating as wire-frame clients. handle-http-client decodes the
|
||
;;; HTTP request, dispatches the body S-expression through the
|
||
;;; SAME handle-request dispatcher used by the TCP else-branch, and
|
||
;;; writes an HTTP/1.1 response with CORS headers so the browser
|
||
;;; playground (https://lumbda.com/playground/) can POST directly
|
||
;;; to a worker running on the user's own machine via
|
||
;;; http://localhost:8321/ (browsers permit localhost without TLS).
|
||
;;;
|
||
;;; Binary-mode forms (BSHK/BCGB/BSCP/BSRT/BSB3) are NOT exposed
|
||
;;; over HTTP — those exist for native callers who already have
|
||
;;; the binary cached locally. HTTP callers either use S-expression
|
||
;;; forms (echo / ping / cuda-shake-fanout / cuda-sim-ops-bin with
|
||
;;; an on-disk path) or, once Phase 2 lands, server-side factory
|
||
;;; ops that compile recipes into binaries before bending them.
|
||
|
||
(define (handle-http-client client)
|
||
(let ((req (read-http-request client)))
|
||
(cond
|
||
((eq? req #f)
|
||
(tcp-close client))
|
||
(else
|
||
(let ((method (car req))
|
||
(body (car (cdr (cdr req)))))
|
||
(cond
|
||
((string=? method "OPTIONS")
|
||
(write-http-options-response client)
|
||
(tcp-close client))
|
||
((string=? method "POST")
|
||
(let* ((sexp (read-from-string body))
|
||
(resp (handle-request sexp))
|
||
;; Pre-formatted text responses (e.g. the bench's
|
||
;; pretty summary) come back as a string; send raw
|
||
;; so the browser sees clean multi-line text
|
||
;; instead of an escape-quoted "\"...\\n...\"".
|
||
;; Structured S-exp responses still get
|
||
;; write-to-string.
|
||
(resp-text (cond
|
||
((string? resp) resp)
|
||
(else (write-to-string resp)))))
|
||
(write-http-response client 200 resp-text
|
||
"text/plain; charset=utf-8")
|
||
(tcp-close client)))
|
||
(else
|
||
(write-http-response client 405
|
||
"Only POST and OPTIONS are supported.\n"
|
||
"text/plain; charset=utf-8")
|
||
(tcp-close client))))))))
|
||
|
||
;; NOTE — fork-self discrimination:
|
||
;; Python tier's (eq? 0 #f) returns #t (== conflates int 0 with bool
|
||
;; False). C tier (eq? identity) returns #f correctly. To stay portable
|
||
;; we use (number? pid) to distinguish "fork failed (#f)" from "child
|
||
;; (numeric 0)". Don't switch to (eq? pid 0) here — works on C/asm but
|
||
;; runs the failed-fork branch in every Python-tier child.
|
||
(define (http-run-loop server)
|
||
(waitpid-nonblock)
|
||
(wait-admit *vram-per-cell-max-mib*)
|
||
(let ((client (tcp-accept server)))
|
||
(cond
|
||
((eq? client #f) (http-run-loop server))
|
||
(else
|
||
(let ((pid (fork-self)))
|
||
(cond
|
||
((not (number? pid))
|
||
;; fork failed — fall back to serial handle
|
||
(handle-http-client client)
|
||
(http-run-loop server))
|
||
((= pid 0)
|
||
;; child: handle one HTTP client, then exit
|
||
(handle-http-client client)
|
||
(exit 0))
|
||
(else
|
||
;; parent: close our copy of client fd, loop to accept
|
||
(tcp-close client)
|
||
(http-run-loop server))))))))
|
||
|
||
;; Optional registration — only spawn the daemon when its binary is
|
||
;; reachable. Lets a worker host serve a subset of forms without
|
||
;; failing to start because some bend form's daemon isn't installed.
|
||
(define (maybe-register-daemon! op-name binary-path . extra-args)
|
||
(cond
|
||
((file-exists? binary-path)
|
||
(if (null? extra-args)
|
||
(register-daemon! op-name binary-path)
|
||
(register-daemon! op-name binary-path (car extra-args))))
|
||
(else
|
||
(display ";;; gpu-worker: skipping ") (display op-name)
|
||
(display " - binary not found at ") (display binary-path)
|
||
(newline))))
|
||
|
||
;; Day-4 daemon flag set for the secp256k1 binary. v3 (--window-w 4)
|
||
;; landed 13.83 Mkeys/s @ n=1M (1.73x v1, 1.55x v4). Day-4 v4 stack
|
||
;; regressed -12% vs v3; daemon stays on v3 until warp-scan Phase B/D
|
||
;; lands (see plans/form-A-day4-progress.md).
|
||
(define *secp-daemon-extra-args* '("--window-w" "4"))
|
||
|
||
;; Dual-port main — wire-TCP on *worker-port* (default 8320), HTTP on
|
||
;; *worker-http-port* (default port+1 = 8321). One fork at startup
|
||
;; splits the process: child runs http-run-loop, parent runs the
|
||
;; existing run-loop. Same handle-request dispatcher fires for both.
|
||
;;
|
||
;; If the HTTP listener fails (port in use, etc.), the worker falls
|
||
;; back to wire-only — the wire path stays the source-of-truth and
|
||
;; the HTTP path is a convenience for browser callers.
|
||
(define (main)
|
||
(let* ((port (parse-port-arg *argv*))
|
||
(http-port (parse-http-port-arg *argv* (+ port 1))))
|
||
(set! *worker-port* port)
|
||
(set! *worker-http-port* http-port)
|
||
(maybe-register-daemon! 'cuda-shake-fanout *binary-shake-fanout*)
|
||
(maybe-register-daemon! 'cuda-bignum-cgbn *binary-cgbn-batch*)
|
||
(maybe-register-daemon! 'cuda-secp256k1-batched-mul
|
||
*binary-secp256k1-batch*
|
||
*secp-daemon-extra-args*)
|
||
(maybe-register-daemon! 'cuda-radix-sort *binary-radix-sort*)
|
||
(maybe-register-daemon! 'cuda-blake3-tree *binary-blake3-fanout*)
|
||
(let ((wire-server (tcp-listen port))
|
||
(http-server (tcp-listen http-port)))
|
||
(cond
|
||
((eq? wire-server #f)
|
||
(display ";;; ERROR -- tcp-listen failed on wire port ")
|
||
(display port) (newline))
|
||
((eq? http-server #f)
|
||
(display ";;; WARN -- tcp-listen failed on http port ")
|
||
(display http-port) (display "; running wire-only") (newline)
|
||
(display "gpu-worker listening on port ")
|
||
(display port) (newline)
|
||
(run-loop wire-server))
|
||
(else
|
||
;; See note above http-run-loop: use (number? pid) not
|
||
;; (eq? pid 0) to discriminate Python-tier's int-0 from #f.
|
||
(let ((http-pid (fork-self)))
|
||
(cond
|
||
((not (number? http-pid))
|
||
(display ";;; WARN -- fork-self failed; running wire-only")
|
||
(newline)
|
||
(tcp-close http-server)
|
||
(display "gpu-worker listening on port ")
|
||
(display port) (newline)
|
||
(run-loop wire-server))
|
||
((= http-pid 0)
|
||
;; child: HTTP loop
|
||
(tcp-close wire-server)
|
||
(display "gpu-worker HTTP listening on port ")
|
||
(display http-port) (newline)
|
||
(http-run-loop http-server))
|
||
(else
|
||
;; parent: wire-TCP loop (existing behavior)
|
||
(tcp-close http-server)
|
||
(display "gpu-worker listening on port ")
|
||
(display port) (newline)
|
||
(run-loop wire-server)))))))))
|
||
|
||
;; (main) ; uncomment to run; needs the cuda-shake-fanout binary
|
||
;; on disk + spawn-process-stdio primitive per tier
|