Make blocking socket FFI collect-safe; fix http-client temp-file race
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`.
This commit is contained in:
parent
4114766c71
commit
6f433a1b3c
4 changed files with 97 additions and 8 deletions
9
Makefile
9
Makefile
|
|
@ -4,7 +4,7 @@
|
||||||
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a
|
# build step. `make test` is the full gate. `make remint` rebuilds the seed after a
|
||||||
# source change.
|
# 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
|
# Full gate (dev machine). Includes the self-host byte-fixpoint, which only holds
|
||||||
# on the same Chez that minted the seed.
|
# 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
|
# 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
|
# 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).
|
# 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"
|
@echo "OK: CI gates passed"
|
||||||
|
|
||||||
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
|
# Self-host fixpoint: bootstrap.ss rebuild == checked-in seed.
|
||||||
|
|
@ -42,6 +42,11 @@ smoke:
|
||||||
sci:
|
sci:
|
||||||
@chez --script host/chez/run-sci.ss
|
@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.
|
# JVM oracle: certify the corpus against reference Clojure. Skips if clojure absent.
|
||||||
certify:
|
certify:
|
||||||
@if command -v clojure >/dev/null 2>&1; then \
|
@if command -v clojure >/dev/null 2>&1; then \
|
||||||
|
|
|
||||||
|
|
@ -41,11 +41,17 @@
|
||||||
(else n))))
|
(else n))))
|
||||||
(else (jolt-str-render-one ct))))
|
(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-counter 0)
|
||||||
(define (hc-tmp-path)
|
(define (hc-tmp-path)
|
||||||
(set! hc-tmp-counter (+ hc-tmp-counter 1))
|
(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-"
|
(string-append (or (getenv "TMPDIR") "/tmp") "/jolt-http-"
|
||||||
(number->string (* 100000 (+ 1 (modulo hc-tmp-counter 90000)))) ".hdr"))
|
(number->string (c-getpid)) "-" (number->string n) ".hdr")))
|
||||||
|
|
||||||
(define (hc-trim s)
|
(define (hc-trim s)
|
||||||
(let* ((n (string-length s))
|
(let* ((n (string-length s))
|
||||||
|
|
|
||||||
|
|
@ -11,11 +11,18 @@
|
||||||
(define c-socket (foreign-procedure "socket" (int int int) int))
|
(define c-socket (foreign-procedure "socket" (int int int) int))
|
||||||
(define c-bind (foreign-procedure "bind" (int void* int) int))
|
(define c-bind (foreign-procedure "bind" (int void* int) int))
|
||||||
(define c-listen (foreign-procedure "listen" (int 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-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))
|
(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)
|
(define AF_INET 2) (define SOCK_STREAM 1)
|
||||||
;; SOL_SOCKET / SO_REUSEADDR differ by platform: macOS uses 0xffff / 4, Linux 1 / 2.
|
;; SOL_SOCKET / SO_REUSEADDR differ by platform: macOS uses 0xffff / 4, Linux 1 / 2.
|
||||||
|
|
|
||||||
71
test/chez/ffi-server-test.ss
Normal file
71
test/chez/ffi-server-test.ss
Normal file
|
|
@ -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))
|
||||||
Loading…
Add table
Add a link
Reference in a new issue