From 6f433a1b3c189b87ce1edc7213eb2f2d9e0abdcc Mon Sep 17 00:00:00 2001 From: Yogthos Date: Mon, 22 Jun 2026 08:12:53 -0400 Subject: [PATCH] Make blocking socket FFI collect-safe; fix http-client temp-file race MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Two thread-safety bugs in the native FFI layer. The HTTP server's accept/recv/send were plain foreign-procedures. A thread inside a foreign call stays active for the stop-the-world collector, so the accept loop sitting idle in accept() froze GC for the whole process whenever another thread (a future, an async block) allocated. Mark the three blocking calls __collect_safe so the thread deactivates for the call's duration — collection proceeds while the accept thread waits. The args are an fd and foreign-alloc'd buffers (outside the Scheme heap), so a collection mid-call has nothing to move. jolt.http-client built its -D header-file path from an unguarded (set! counter (+ counter 1)) and counter mod 90000, with no per-process component. Concurrent requests could compute the same path and clobber each other's headers. Use a mutex-guarded monotonic counter plus the pid. test/chez/ffi-server-test.ss exercises both (a (collect) while the server is idle in accept(), temp-path uniqueness across threads, and a live request) and is wired into the gate as `make ffi`. --- Makefile | 9 ++++- host/chez/http-client.ss | 12 ++++-- host/chez/http-server.ss | 13 +++++-- test/chez/ffi-server-test.ss | 71 ++++++++++++++++++++++++++++++++++++ 4 files changed, 97 insertions(+), 8 deletions(-) create mode 100644 test/chez/ffi-server-test.ss diff --git a/Makefile b/Makefile index b10bbb0..0289c3f 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ # build step. `make test` is the full gate. `make remint` rebuilds the seed after a # source change. -.PHONY: test ci values corpus unit smoke selfhost sci certify remint +.PHONY: test ci values corpus unit smoke selfhost sci certify ffi remint # Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds # on the same Chez that minted the seed. @@ -15,7 +15,7 @@ test: selfhost ci # lockfile) — it RUNS correctly on any Chez, but `selfhost` rebuilds it and a # different Chez version may emit byte-different (gensym/order) output, so the # byte-fixpoint is a dev-machine check, not a CI one (jolt-8479). -ci: values corpus unit smoke sci certify +ci: values corpus unit smoke sci ffi certify @echo "OK: CI gates passed" # Self-host fixpoint: bootstrap.ss rebuild == checked-in seed. @@ -42,6 +42,11 @@ smoke: sci: @chez --script host/chez/run-sci.ss +# FFI + threading: HTTP server GC-safety (blocking calls deactivate the thread) +# and http-client temp-file uniqueness, plus a live request. +ffi: + @chez --script test/chez/ffi-server-test.ss + # JVM oracle: certify the corpus against reference Clojure. Skips if clojure absent. certify: @if command -v clojure >/dev/null 2>&1; then \ diff --git a/host/chez/http-client.ss b/host/chez/http-client.ss index 6a18090..7c19bb2 100644 --- a/host/chez/http-client.ss +++ b/host/chez/http-client.ss @@ -41,11 +41,17 @@ (else n)))) (else (jolt-str-render-one ct)))) +;; A per-request header file path, unique across processes (PID) and threads (a +;; mutex-guarded monotonic counter). The previous unguarded `set!` + `mod 90000` +;; raced: concurrent callers could compute the same path and clobber each other's +;; -D header dump. getpid is a fast, non-blocking foreign call. +(define c-getpid (begin (load-shared-object #f) (foreign-procedure "getpid" () int))) +(define hc-tmp-mutex (make-mutex)) (define hc-tmp-counter 0) (define (hc-tmp-path) - (set! hc-tmp-counter (+ hc-tmp-counter 1)) - (string-append (or (getenv "TMPDIR") "/tmp") "/jolt-http-" - (number->string (* 100000 (+ 1 (modulo hc-tmp-counter 90000)))) ".hdr")) + (let ((n (with-mutex hc-tmp-mutex (set! hc-tmp-counter (+ hc-tmp-counter 1)) hc-tmp-counter))) + (string-append (or (getenv "TMPDIR") "/tmp") "/jolt-http-" + (number->string (c-getpid)) "-" (number->string n) ".hdr"))) (define (hc-trim s) (let* ((n (string-length s)) diff --git a/host/chez/http-server.ss b/host/chez/http-server.ss index 8a7f930..b59995d 100644 --- a/host/chez/http-server.ss +++ b/host/chez/http-server.ss @@ -11,11 +11,18 @@ (define c-socket (foreign-procedure "socket" (int int int) int)) (define c-bind (foreign-procedure "bind" (int void* int) int)) (define c-listen (foreign-procedure "listen" (int int) int)) -(define c-accept (foreign-procedure "accept" (int void* void*) int)) (define c-setsockopt (foreign-procedure "setsockopt" (int int int void* int) int)) -(define c-recv (foreign-procedure "recv" (int void* size_t int) ssize_t)) -(define c-send (foreign-procedure "send" (int void* size_t int) ssize_t)) (define c-close (foreign-procedure "close" (int) int)) +;; accept/recv/send can BLOCK (accept indefinitely while idle). A thread inside a +;; plain foreign call stays "active" and stalls the stop-the-world collector for +;; every thread, so the accept loop would freeze GC process-wide whenever a future +;; or async block allocates while no request is in flight. __collect_safe +;; deactivates the calling thread for the call's duration so collection proceeds. +;; Safe here: the only arguments are an fd and foreign-alloc'd buffers (outside the +;; Scheme heap), so a collection during the call has nothing to move. +(define c-accept (foreign-procedure __collect_safe "accept" (int void* void*) int)) +(define c-recv (foreign-procedure __collect_safe "recv" (int void* size_t int) ssize_t)) +(define c-send (foreign-procedure __collect_safe "send" (int void* size_t int) ssize_t)) (define AF_INET 2) (define SOCK_STREAM 1) ;; SOL_SOCKET / SO_REUSEADDR differ by platform: macOS uses 0xffff / 4, Linux 1 / 2. diff --git a/test/chez/ffi-server-test.ss b/test/chez/ffi-server-test.ss new file mode 100644 index 0000000..1925baa --- /dev/null +++ b/test/chez/ffi-server-test.ss @@ -0,0 +1,71 @@ +;; FFI + threading regression. Run from repo root: +;; chez --script test/chez/ffi-server-test.ss +;; +;; Covers two fixes: +;; - the HTTP server's blocking accept/recv/send are __collect_safe, so a thread +;; idle in accept() no longer pins the stop-the-world collector. With the bug, +;; a (collect) on the main thread throws "cannot collect when multiple threads +;; are active"; with the fix it succeeds while the server sits in accept(). +;; - jolt.http-client temp-file paths are unique per process+thread (no clobber). +;; Plus a live request end to end (server thread wakes from accept and responds). + +(import (chezscheme)) + +;; mirror cli.ss's load sequence through http-server.ss +(load "host/chez/rt.ss") +(set-chez-ns! "clojure.core") +(load "host/chez/seed/prelude.ss") +(load "host/chez/post-prelude.ss") +(set-chez-ns! "user") +(load "host/chez/host-contract.ss") +(load "host/chez/seed/image.ss") +(load "host/chez/compile-eval.ss") +(load "host/chez/png.ss") +(load "host/chez/http-client.ss") +(load "host/chez/sqlite.ss") +(load "host/chez/http-server.ss") +(load "host/chez/loader.ss") ; defines jolt-sh-out, used by http-client + +(define total 0) (define fails 0) +(define (ok name pred) (set! total (+ total 1)) (unless pred (set! fails (+ fails 1)) (printf "FAIL: ~a\n" name))) + +(define port 8391) +(define run-server (var-deref "jolt.http.server" "run-server")) +(define stop-server (var-deref "jolt.http.server" "stop-server")) +(define http-get (var-deref "jolt.http-client" "get")) + +(define (kw s) (keyword #f s)) +(define handler (lambda (req) (jolt-hash-map (kw "status") 200 (kw "body") "hi from test"))) +(define server (jolt-invoke run-server handler (jolt-hash-map (kw "port") port))) + +;; let the accept thread reach accept() (sleep is collect-safe in Chez) +(sleep (make-time 'time-duration 300000000 0)) + +;; GC must proceed even though a thread is blocked in accept(): a stalled +;; collector throws "cannot collect when multiple threads are active". +(ok "collect not stalled by idle accept()" (guard (e (#t #f)) (collect) #t)) + +;; client temp paths: unique under concurrency. Exercise the private path +;; generator via reflection-free duplication of its guarantee — many threads, +;; all distinct. +(let ((seen (make-hashtable string-hash string=?)) (m (make-mutex)) (dups 0)) + (define threads + (map (lambda (_) (fork-thread (lambda () + (let loop ((i 0)) (when (< i 1000) + (let ((p (hc-tmp-path))) (with-mutex m (if (hashtable-ref seen p #f) (set! dups (+ dups 1)) (hashtable-set! seen p #t)))) + (loop (+ i 1))))))) + (iota 6))) + (sleep (make-time 'time-duration 400000000 0)) + (ok "http-client temp paths unique across threads" (= dups 0))) + +;; live request end to end +(let* ((resp (jolt-invoke http-get (string-append "http://127.0.0.1:" (number->string port) "/"))) + (status (jolt-get resp (kw "status"))) + (body (jolt-get resp (kw "body")))) + (ok "live GET status 200" (eqv? 200 status)) + (ok "live GET body" (and (string? body) (string=? body "hi from test")))) + +(jolt-invoke stop-server server) + +(printf "~a/~a passed~n" (- total fails) total) +(exit (if (zero? fails) 0 1))