jolt.ffi: a :blocking option for collect-safe foreign calls

A library binding a blocking native call (accept/recv/connect/...) needs it
emitted __collect_safe so the thread deactivates for the call and doesn't pin
the stop-the-world collector. foreign-fn / defcfn take an optional trailing
:blocking; the backend emits (foreign-procedure __collect_safe ...). Needed for
the ring-janet-adapter socket-server port. ffi-binding-test asserts a thread
parked in a :blocking call doesn't block (collect).

jolt-core/jolt/analyzer.clj

@@ -395,17 +395,21 @@
 
 ;; jolt.ffi/__cfn (jolt-ffi): the low-level foreign-function form a jolt library
 ;; uses (via the jolt.ffi/foreign-fn macro) to bind native code. Shape:
-;;   (jolt.ffi/__cfn "c_symbol" [:argtype ...] :rettype)
+;;   (jolt.ffi/__cfn "c_symbol" [:argtype ...] :rettype)            ; non-blocking
+;;   (jolt.ffi/__cfn "c_symbol" [:argtype ...] :rettype :blocking)  ; may block
 ;; The C symbol is a string literal and the types are literal keywords, read here
 ;; at compile time; the Chez back end lowers it to a real `foreign-procedure`
-;; (typed marshaling, no runtime eval). A leaf IR node.
+;; (typed marshaling, no runtime eval). A :blocking call is emitted __collect_safe
+;; so it deactivates the thread for the call — a blocking call (accept/recv/...)
+;; must not pin the stop-the-world collector. A leaf IR node.
 (defn- analyze-ffi-fn [ctx items env]
-  (when (not= 4 (count items))
-    (throw (str "jolt.ffi/foreign-fn expects (foreign-fn \"sym\" [argtypes] rettype)")))
+  (when-not (<= 4 (count items) 5)
+    (throw (str "jolt.ffi/foreign-fn expects (foreign-fn \"sym\" [argtypes] rettype [:blocking])")))
   {:op :ffi-fn
    :csym (nth items 1)
    :argtypes (mapv name (form-vec-items (nth items 2)))
-   :rettype (name (nth items 3))})
+   :rettype (name (nth items 3))
+   :blocking (and (= 5 (count items)) (= "blocking" (name (nth items 4))))})
 
 ;; The `.` special form: `(. target member arg*)` — member access / method call.
 ;; A symbol member whose name starts with "-" is a field read; otherwise it is a

jolt-core/jolt/backend_scheme.clj

@@ -292,7 +292,7 @@
 (defn- ffi-type->chez [t]
   (or (ffi-types t) (throw (ex-info (str "jolt.ffi: unknown foreign type :" t) {}))))
 (defn- emit-ffi-fn [node]
-  (str "(foreign-procedure " (chez-str-lit (:csym node))
+  (str "(foreign-procedure " (when (:blocking node) "__collect_safe ") (chez-str-lit (:csym node))
        " (" (str/join " " (map ffi-type->chez (:argtypes node))) ") "
        (ffi-type->chez (:rettype node)) ")"))
 

src/jolt/jolt/ffi.clj

@@ -21,9 +21,15 @@
 ;; foreign-fn binds C symbol `csym` to a typed callable. Expands to the __cfn
 ;; special form (always fully-qualified, so an :as alias on jolt.ffi resolves):
 ;; the analyzer/back end turn it into a Chez foreign-procedure.
-(defmacro foreign-fn [csym argtypes rettype]
-  (list 'jolt.ffi/__cfn csym argtypes rettype))
+;; An optional trailing :blocking marks a call that may block (accept/recv/...),
+;; so it's emitted collect-safe and won't pin the garbage collector.
+(defmacro foreign-fn [csym argtypes rettype & [opt]]
+  (if (= opt :blocking)
+    (list 'jolt.ffi/__cfn csym argtypes rettype :blocking)
+    (list 'jolt.ffi/__cfn csym argtypes rettype)))
 
-;; (defcfn name "c_symbol" [argtypes] rettype) — def a foreign function.
-(defmacro defcfn [name csym argtypes rettype]
-  (list 'def name (list 'jolt.ffi/__cfn csym argtypes rettype)))
+;; (defcfn name "c_symbol" [argtypes] rettype [:blocking]) — def a foreign function.
+(defmacro defcfn [name csym argtypes rettype & [opt]]
+  (list 'def name (if (= opt :blocking)
+                    (list 'jolt.ffi/__cfn csym argtypes rettype :blocking)
+                    (list 'jolt.ffi/__cfn csym argtypes rettype))))

test/chez/ffi-binding-test.ss

@@ -39,5 +39,14 @@
                      (let [v (jolt.ffi/read p :int)] (jolt.ffi/free p) v))"))))
 (ok "sizeof :pointer is a word" (let ((n (jnum->exact (ev "(jolt.ffi/sizeof :pointer)")))) (or (= n 8) (= n 4))))
 
+;; a :blocking foreign call is collect-safe: a thread parked in it must not pin
+;; the stop-the-world collector. (collect) here would throw "cannot collect when
+;; multiple threads are active" if usleep weren't emitted __collect_safe.
+(ev "(def c-usleep (jolt.ffi/__cfn \"usleep\" [:uint] :int :blocking))")
+(let ((usleep (var-deref "user" "c-usleep")))
+  (fork-thread (lambda () (usleep 2000000)))           ; ~2s in a blocking call
+  (let loop ((i 0)) (when (fx<? i 30000000) (loop (fx+ i 1))))  ; spin so the thread enters usleep
+  (ok "blocking ffi call is collect-safe" (guard (e (#t #f)) (collect) #t)))
+
 (printf "~a/~a passed~n" (- total fails) total)
 (exit (if (zero? fails) 0 1))