ffi: foreign-callable — receive callbacks from C

jolt could call C (foreign-fn -> foreign-procedure) but C could not call back
into jolt, which GTK signals (and any callback-taking C API) require. Add the
inverse: jolt.ffi/foreign-callable wraps a jolt fn as a C-callable function
pointer, mirroring the foreign-fn pipeline.

A new jolt.ffi/__ccallable special form carries the fn as a child expression
(analyzed + walked by the passes; ir.clj gains an :ffi-callable arm in both
child walks) plus literal arg/ret type keywords. The back end lowers it to a
locked Chez foreign-callable and returns its entry-point address as a jolt
pointer; host/chez/ffi.ss registers the code object so the collector keeps it,
and free-callable unlocks it. :collect-safe emits the convention that
reactivates the thread on entry, for callbacks fired while it is parked in a
:blocking call (a GTK main loop).

Test: ffi-binding-test.ss sorts an int array through libc qsort with a jolt
comparator (C -> jolt -> C). Re-minted seed.

host/chez/ffi.ss

@@ -116,7 +116,26 @@
     (foreign-set! 'unsigned-8 p n 0)
     p))
 
+;; --- callbacks: receive calls FROM C ----------------------------------------
+;; jolt.ffi/foreign-callable lowers to (jolt-ffi-register-callable! (foreign-callable …)).
+;; A foreign-callable code object must be LOCKED (so the collector neither moves
+;; nor reclaims it) and RETAINED while C may still call through its entry point.
+;; Register it keyed by that entry-point address (a jolt pointer integer) — which
+;; is what the caller hands to C; free-callable unlocks and drops it. A callback
+;; left registered lives for the process (the GTK-signal-handler common case).
+(define ffi-callable-table (make-eqv-hashtable))   ; entry-point addr -> code object
+(define (jolt-ffi-register-callable! co)
+  (lock-object co)
+  (let ((addr (foreign-callable-entry-point co)))
+    (hashtable-set! ffi-callable-table addr co)
+    addr))
+(define (ffi-free-callable addr)
+  (let* ((a (jnum->exact addr)) (co (hashtable-ref ffi-callable-table a #f)))
+    (when co (unlock-object co) (hashtable-delete! ffi-callable-table a))
+    jolt-nil))
+
 ;; --- expose under jolt.ffi ---------------------------------------------------
+(def-var! "jolt.ffi" "free-callable" ffi-free-callable)
 (def-var! "jolt.ffi" "load-library" ffi-load-library)
 (def-var! "jolt.ffi" "loaded?" (lambda (n) (if (ffi-loaded? n) #t #f)))
 (def-var! "jolt.ffi" "alloc" ffi-alloc)

jolt-core/jolt/analyzer.clj

@@ -424,6 +424,28 @@
    :rettype (name (nth items 3))
    :blocking (and (= 5 (count items)) (= "blocking" (name (nth items 4))))})
 
+;; jolt.ffi/__ccallable: the foreign-CALLBACK form (via the jolt.ffi/foreign-callable
+;; macro) — the inverse of __cfn. It wraps a jolt fn as a C-callable function
+;; pointer so C can call back INTO jolt (GTK signal handlers, qsort comparators).
+;; Shape:
+;;   (jolt.ffi/__ccallable f [:argtype ...] :rettype)                ; thread stays active
+;;   (jolt.ffi/__ccallable f [:argtype ...] :rettype :collect-safe)  ; may be invoked
+;;                                                                   ; while the thread is
+;;                                                                   ; parked in a :blocking call
+;; Unlike __cfn, the fn is a CHILD expression (analyzed + walked by the passes);
+;; the types are literal keywords read at compile time. The Chez back end lowers
+;; it to a locked `foreign-callable` and returns its entry-point address (a jolt
+;; pointer). :collect-safe is required when C invokes the callback from a thread
+;; that is deactivated inside a :blocking foreign call (e.g. a GTK main loop).
+(defn- analyze-ffi-callable [ctx items env]
+  (when-not (<= 4 (count items) 5)
+    (throw (str "jolt.ffi/foreign-callable expects (foreign-callable f [argtypes] rettype [:collect-safe])")))
+  {:op :ffi-callable
+   :fn (analyze ctx (nth items 1) env)
+   :argtypes (mapv name (form-vec-items (nth items 2)))
+   :rettype (name (nth items 3))
+   :collect-safe (and (= 5 (count items)) (= "collect-safe" (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
 ;; method (call with the trailing args). Both lower to a :host-call carrying the
@@ -506,6 +528,11 @@
           (and (form-sym? head) (= "jolt.ffi" (form-sym-ns head))
                (= "__cfn" (form-sym-name head)))
             (analyze-ffi-fn ctx items env)
+          ;; jolt.ffi/__ccallable — the foreign-callback special form (the fn is a
+          ;; child expression, analyzed here).
+          (and (form-sym? head) (= "jolt.ffi" (form-sym-ns head))
+               (= "__ccallable" (form-sym-name head)))
+            (analyze-ffi-callable ctx items env)
           ;; special-form heads are NOT shadowable (unlike macros): a local named
           ;; `if` does not change the meaning of (if …) in operator position, per
           ;; spec §3 and the reference. No (not shadowed) guard here.

jolt-core/jolt/backend_scheme.clj

@@ -287,6 +287,19 @@
        " (" (str/join " " (map ffi-type->chez (:argtypes node))) ") "
        (ffi-type->chez (:rettype node)) ")"))
 
+;; jolt.ffi/__ccallable -> a Chez foreign-callable wrapping the emitted jolt fn,
+;; locked + registered (jolt-ffi-register-callable!, host/chez/ffi.ss) so the
+;; collector neither moves nor reclaims it while C may still call through it. The
+;; expression evaluates to the entry-point address — a jolt pointer the caller
+;; hands to C. :collect-safe emits the convention that reactivates the thread on
+;; entry, for callbacks invoked while it is parked in a :blocking foreign call.
+(defn- emit-ffi-callable [node]
+  (str "(jolt-ffi-register-callable! (foreign-callable "
+       (when (:collect-safe node) "__collect_safe ")
+       (emit (:fn node))
+       " (" (str/join " " (map ffi-type->chez (:argtypes node))) ") "
+       (ffi-type->chez (:rettype node)) "))"))
+
 (defn- emit-recur [node]
   (when-not *recur-target* (throw (ex-info "emit: recur outside a loop/fn target" {})))
   (let [arg-nodes (:args node)]
@@ -500,6 +513,7 @@
     :loop (emit-loop node)
     :recur (emit-recur node)
     :ffi-fn (emit-ffi-fn node)
+    :ffi-callable (emit-ffi-callable node)
     :fn (emit-fn node)
     ;; (def name) with no init (declare): reserve the cell. A def with non-empty
     ;; reader metadata lowers to def-var-with-meta! (ported in a later increment).

jolt-core/jolt/ir.clj

@@ -94,6 +94,7 @@
       (= op :set-var) (assoc node :val (f (get node :val)))
       (= op :set-field) (assoc node :obj (f (get node :obj)) :val (f (get node :val)))
       (= op :defmacro) (assoc node :fn (f (get node :fn)))
+      (= op :ffi-callable) (assoc node :fn (f (get node :fn)))
       (= op :invoke) (assoc node :fn (f (get node :fn))
                                  :args (mapv f (get node :args)))
       (= op :vector) (assoc node :items (mapv f (get node :items)))
@@ -140,6 +141,7 @@
       (= op :set-var) (f acc (get node :val))
       (= op :set-field) (f (f acc (get node :obj)) (get node :val))
       (= op :defmacro) (f acc (get node :fn))
+      (= op :ffi-callable) (f acc (get node :fn))
       (= op :invoke) (reduce f (f acc (get node :fn)) (get node :args))
       (= op :vector) (reduce f acc (get node :items))
       (= op :set) (reduce f acc (get node :items))

stdlib/jolt/ffi.clj

@@ -16,7 +16,9 @@
 
   The memory/library primitives (alloc/free/read/write/sizeof/load-library/
   ptr->string/string->ptr/null/null?) are provided by the host. foreign-fn lowers
-  a compile-time-typed signature to a real Chez foreign-procedure.")
+  a compile-time-typed signature to a real Chez foreign-procedure. foreign-callable
+  is the inverse — it wraps a jolt fn as a C-callable function pointer so C can
+  call back into jolt (e.g. GTK signal handlers); free-callable releases it.")
 
 ;; 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):
@@ -33,3 +35,19 @@
   (list 'def name (if (= opt :blocking)
                     (list 'jolt.ffi/__cfn csym argtypes rettype :blocking)
                     (list 'jolt.ffi/__cfn csym argtypes rettype))))
+
+;; foreign-callable wraps a jolt fn `f` as a C-callable function pointer — the
+;; inverse of foreign-fn, so C can call back INTO jolt (GTK signal handlers, a
+;; qsort comparator, any C API that takes a callback). Returns the pointer; pass
+;; it where C expects a function pointer. argtypes/rettype use the same keywords
+;; as foreign-fn; the args C passes arrive as jolt values and the jolt return is
+;; marshaled back. The callback stays live until free-callable is called on the
+;; pointer. Pass a trailing :collect-safe when C invokes the callback from a
+;; thread parked in a :blocking foreign call (e.g. a GTK main loop):
+;;   (g-signal-connect button "clicked"
+;;                     (ffi/foreign-callable on-click [:pointer :pointer] :void :collect-safe)
+;;                     (ffi/null))
+(defmacro foreign-callable [f argtypes rettype & [opt]]
+  (if (= opt :collect-safe)
+    (list 'jolt.ffi/__ccallable f argtypes rettype :collect-safe)
+    (list 'jolt.ffi/__ccallable f argtypes rettype)))

test/chez/ffi-binding-test.ss

@@ -61,5 +61,29 @@
   (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)))
 
+;; callbacks: receive a call FROM C. A foreign-callable wraps a jolt fn as a
+;; C-callable function pointer (what GTK signal handlers / qsort comparators need).
+;; Build a comparator and sort an int array through libc qsort.
+(ev "(def cmp (jolt.ffi/__ccallable
+                (fn [pa pb]
+                  (let [a (jolt.ffi/read pa :int) b (jolt.ffi/read pb :int)]
+                    (cond (< a b) -1 (> a b) 1 :else 0)))
+                [:pointer :pointer] :int))")
+(ok "foreign-callable returns a pointer"
+    (let ((p (jnum->exact (var-deref "user" "cmp")))) (and (integer? p) (> p 0))))
+(ev "(def c-qsort (jolt.ffi/__cfn \"qsort\" [:pointer :size_t :size_t :pointer] :void))")
+(ok "C calls back into jolt: qsort with a jolt comparator"
+    (jolt-truthy?
+      (ev "(let [n 5 w (jolt.ffi/sizeof :int) p (jolt.ffi/alloc (* n w))]
+             (doseq [[i v] (map vector (range n) [3 1 4 1 5])]
+               (jolt.ffi/write p :int (* i w) v))
+             (c-qsort p n w cmp)
+             (let [out (mapv (fn [i] (jolt.ffi/read p :int (* i w))) (range n))]
+               (jolt.ffi/free p)
+               (= out [1 1 3 4 5])))")))
+;; free-callable unlocks + drops the code object, returning nil.
+(ok "free-callable releases the callback"
+    (jolt-nil? (ev "(jolt.ffi/free-callable cmp)")))
+
 (printf "~a/~a passed~n" (- total fails) total)
 (exit (if (zero? fails) 0 1))