fix GC-unsafe __collect_safe FFI bindings (agent-worker segfault)
ober
c9464ed4cb4e670195808306cd75dbc82254e956
--- a/src/jcode/core/path-policy.ss +++ b/src/jcode/core/path-policy.ss @@ -41,8 +41,43 @@ (foreign-procedure "fchmod" (int int) int)) (def c-fsync (foreign-procedure __collect_safe "fsync" (int) int)) -(def c-write - (foreign-procedure __collect_safe "write" (int u8* unsigned-long) long)) +;; Raw libc write(2) -- void* only. A __collect_safe call parks the +;; thread in the kernel with the TC mutex released, so the moving +;; collector can relocate a Scheme bytevector handed over as u8*; the +;; kernel then writes from a stale address (heap corruption, later +;; "invalid memory reference" crashes). All calls bounce through the +;; scoped foreign buffer in c-write below. +(def c-write-raw + (foreign-procedure __collect_safe "write" (int void* unsigned-long) long)) + +;; Largest single write(2) attempted; write-all! loops for the rest. +;; Bounds the native copy even for multi-megabyte contents. +(def *c-write-chunk-max* 65536) + +(def (copy-bv->foreign! bv ptr len) + (do ((i 0 (+ i 1))) + ((>= i len)) + (foreign-set! 'unsigned-8 ptr i (bytevector-u8-ref bv i)))) + +(def (c-write fd bv len) + ;; Same contract as the raw binding (returns bytes written, <= LEN) + ;; but bounces through a scoped foreign buffer so a blocked + ;; collect-safe write never holds a movable Scheme address across a GC. + (unless (bytevector? bv) + (error 'c-write "expected bytevector" bv)) + (unless (and (integer? len) (exact? len) (>= len 0) + (<= len (bytevector-length bv))) + (error 'c-write "write length exceeds bytevector capacity" + len (bytevector-length bv))) + (let ((n-req (min len *c-write-chunk-max*))) + (let ((ptr (foreign-alloc (max 1 n-req)))) + (unless (and ptr (not (= ptr 0))) + (error 'c-write "foreign buffer allocation failed" n-req)) + (dynamic-wind void + (lambda () + (copy-bv->foreign! bv ptr n-req) + (c-write-raw fd ptr n-req)) + (lambda () (foreign-free ptr)))))) (def c-dup (foreign-procedure "dup" (int) int)) --- a/src/jcode/provider/http.ss +++ b/src/jcode/provider/http.ss @@ -176,12 +176,12 @@ ;; These bindings declare __collect_safe so the scheduler can switch ;; threads while the C side is parked in a syscall. Same pattern as the ;; termbox poll binding in src/jcode/ui/tui-ffi.ss. -(def jcode-tls-read +(def c-jcode-tls-read (foreign-procedure __collect_safe "jerboa_tls_read" - (unsigned-64 u8* unsigned-64) int)) -(def jcode-tls-write + (unsigned-64 void* unsigned-64) int)) +(def c-jcode-tls-write (foreign-procedure __collect_safe "jerboa_tls_write" - (unsigned-64 u8* unsigned-64) int)) + (unsigned-64 void* unsigned-64) int)) (def jcode-tls-flush (foreign-procedure __collect_safe "jerboa_tls_flush" (unsigned-64) int)) @@ -189,6 +189,66 @@ (foreign-procedure __collect_safe "jerboa_tls_close" (unsigned-64) void)) +;; GC-safety: a __collect_safe call releases the TC mutex, so the moving +;; collector can relocate Scheme objects while the C side is parked in a +;; syscall. Handing rustls a movable bytevector as u8* lets it read or +;; write a stale address after a GC -- this is the "invalid memory +;; reference" segfault that ~/.jcode/crash.log records for the agent +;; worker. The raw bindings above therefore take void* and every call +;; bounces through a scoped foreign buffer (same pattern as +;; call-with-rustls-io-buffer in (std net tls-rustls)). +(def (with-tls-buffer-freed ptr k) + (dynamic-wind void + (lambda () (k ptr)) + (lambda () (foreign-free ptr)))) + +(def (call-with-tls-io-buffer who size k) + (unless (and (integer? size) (exact? size) (>= size 0)) + (error who "invalid TLS foreign buffer size" size)) + (let ((ptr (foreign-alloc (max 1 size)))) + (unless (and ptr (not (= ptr 0))) + (error who "TLS foreign buffer allocation failed" size)) + (with-tls-buffer-freed ptr k))) + +(def (check-tls-bv-args who buf len) + (unless (bytevector? buf) + (error who "expected bytevector" buf)) + (unless (and (integer? len) (exact? len) (>= len 0) + (<= len (bytevector-length buf))) + (error who "TLS length exceeds bytevector capacity" + len (bytevector-length buf)))) + +(def (copy-tls-input! who bv ptr len) + (check-tls-bv-args who bv len) + (do ((i 0 (+ i 1))) + ((>= i len)) + (foreign-set! 'unsigned-8 ptr i (bytevector-u8-ref bv i)))) + +(def (copy-tls-output! who ptr bv len) + (check-tls-bv-args who bv len) + (do ((i 0 (+ i 1))) + ((>= i len)) + (bytevector-u8-set! bv i (foreign-ref 'unsigned-8 ptr i)))) + +;; Bytevector API used by every I/O helper below. Signatures match the +;; old raw u8* bindings; the foreign copy keeps the moving collector +;; from ever handing rustls a stale address across a blocked call. +(def (jcode-tls-read conn buf max-len) + (check-tls-bv-args 'jcode-tls-read buf max-len) + (call-with-tls-io-buffer 'jcode-tls-read max-len + (lambda (tmp) + (let ((n (c-jcode-tls-read conn tmp max-len))) + (when (> n 0) + (copy-tls-output! 'jcode-tls-read tmp buf n)) + n)))) + +(def (jcode-tls-write conn buf len) + (check-tls-bv-args 'jcode-tls-write buf len) + (call-with-tls-io-buffer 'jcode-tls-write len + (lambda (tmp) + (copy-tls-input! 'jcode-tls-write buf tmp len) + (c-jcode-tls-write conn tmp len)))) + ;; TLS I/O: write full string via rustls (def (tls-write-string conn s) (let ((bv (string->utf8 s))) --- a/src/jcode/provider/provider.ss +++ b/src/jcode/provider/provider.ss @@ -317,12 +317,12 @@ ;; These bindings declare __collect_safe so the scheduler can switch ;; threads while the C side is parked in a syscall. Same pattern as the ;; termbox poll binding in src/jcode/ui/tui-ffi.ss. -(def jcode-tls-read +(def c-jcode-tls-read (foreign-procedure __collect_safe "jerboa_tls_read" - (unsigned-64 u8* unsigned-64) int)) -(def jcode-tls-write + (unsigned-64 void* unsigned-64) int)) +(def c-jcode-tls-write (foreign-procedure __collect_safe "jerboa_tls_write" - (unsigned-64 u8* unsigned-64) int)) + (unsigned-64 void* unsigned-64) int)) (def jcode-tls-flush (foreign-procedure __collect_safe "jerboa_tls_flush" (unsigned-64) int)) @@ -330,6 +330,66 @@ (foreign-procedure __collect_safe "jerboa_tls_close" (unsigned-64) void)) +;; GC-safety: a __collect_safe call releases the TC mutex, so the moving +;; collector can relocate Scheme objects while the C side is parked in a +;; syscall. Handing rustls a movable bytevector as u8* lets it read or +;; write a stale address after a GC -- this is the "invalid memory +;; reference" segfault that ~/.jcode/crash.log records for the agent +;; worker. The raw bindings above therefore take void* and every call +;; bounces through a scoped foreign buffer (same pattern as +;; call-with-rustls-io-buffer in (std net tls-rustls)). +(def (with-tls-buffer-freed ptr k) + (dynamic-wind void + (lambda () (k ptr)) + (lambda () (foreign-free ptr)))) + +(def (call-with-tls-io-buffer who size k) + (unless (and (integer? size) (exact? size) (>= size 0)) + (error who "invalid TLS foreign buffer size" size)) + (let ((ptr (foreign-alloc (max 1 size)))) + (unless (and ptr (not (= ptr 0))) + (error who "TLS foreign buffer allocation failed" size)) + (with-tls-buffer-freed ptr k))) + +(def (check-tls-bv-args who buf len) + (unless (bytevector? buf) + (error who "expected bytevector" buf)) + (unless (and (integer? len) (exact? len) (>= len 0) + (<= len (bytevector-length buf))) + (error who "TLS length exceeds bytevector capacity" + len (bytevector-length buf)))) + +(def (copy-tls-input! who bv ptr len) + (check-tls-bv-args who bv len) + (do ((i 0 (+ i 1))) + ((>= i len)) + (foreign-set! 'unsigned-8 ptr i (bytevector-u8-ref bv i)))) + +(def (copy-tls-output! who ptr bv len) + (check-tls-bv-args who bv len) + (do ((i 0 (+ i 1))) + ((>= i len)) + (bytevector-u8-set! bv i (foreign-ref 'unsigned-8 ptr i)))) + +;; Bytevector API used by every I/O helper below. Signatures match the +;; old raw u8* bindings; the foreign copy keeps the moving collector +;; from ever handing rustls a stale address across a blocked call. +(def (jcode-tls-read conn buf max-len) + (check-tls-bv-args 'jcode-tls-read buf max-len) + (call-with-tls-io-buffer 'jcode-tls-read max-len + (lambda (tmp) + (let ((n (c-jcode-tls-read conn tmp max-len))) + (when (> n 0) + (copy-tls-output! 'jcode-tls-read tmp buf n)) + n)))) + +(def (jcode-tls-write conn buf len) + (check-tls-bv-args 'jcode-tls-write buf len) + (call-with-tls-io-buffer 'jcode-tls-write len + (lambda (tmp) + (copy-tls-input! 'jcode-tls-write buf tmp len) + (c-jcode-tls-write conn tmp len)))) + ;; TLS I/O: write full string via rustls (def (tls-write-string conn s) (let ((bv (string->utf8 s)))