c91b6092bc
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.
89 lines
4.4 KiB
Scheme
89 lines
4.4 KiB
Scheme
;; jolt.ffi regression: a compile-time-typed foreign binding lowers to a real
|
|
;; Chez foreign-procedure and calls native code. Run:
|
|
;; chez --script test/chez/ffi-binding-test.ss
|
|
;; Binds a few libc functions (process symbols, always present) through the
|
|
;; jolt.ffi/__cfn special form + the host memory primitives — the same path a
|
|
;; library uses to bind its native deps.
|
|
|
|
(import (chezscheme))
|
|
(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/ffi.ss")
|
|
|
|
(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)))
|
|
;; eval one form (string) in `user`, like the loader does form-by-form, so a def
|
|
;; is visible to a later form.
|
|
(define (ev s) (jolt-compile-eval s "user"))
|
|
|
|
;; load libc (process symbols) and bind typed foreign functions
|
|
(ev "(jolt.ffi/load-library)")
|
|
(ev "(def c-strlen (jolt.ffi/__cfn \"strlen\" [:string] :size_t))")
|
|
(ev "(def c-abs (jolt.ffi/__cfn \"abs\" [:int] :int))")
|
|
|
|
(ok "foreign-procedure built for strlen" (procedure? (var-deref "user" "c-strlen")))
|
|
(ok "typed call: strlen(\"hello\") = 5" (= 5 (jnum->exact (ev "(c-strlen \"hello\")"))))
|
|
(ok "typed call: abs(-7) = 7" (= 7 (jnum->exact (ev "(c-abs -7)"))))
|
|
|
|
;; memory: alloc / write / read roundtrip through the host primitives
|
|
(ok "mem int roundtrip"
|
|
(= 4242 (jnum->exact
|
|
(ev "(let [p (jolt.ffi/alloc (jolt.ffi/sizeof :int))]
|
|
(jolt.ffi/write p :int 0 4242)
|
|
(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))))
|
|
|
|
;; byte-array buffer I/O: write a byte-array into foreign memory and read it back
|
|
;; byte-exact (high bytes preserved, no UTF-8 mangling).
|
|
(ok "byte-array roundtrip (binary-faithful)"
|
|
(jolt-truthy?
|
|
(ev "(let [src (byte-array [0 65 200 255 10])
|
|
p (jolt.ffi/alloc 5)]
|
|
(jolt.ffi/write-array p src)
|
|
(let [back (jolt.ffi/read-array p 5)]
|
|
(jolt.ffi/free p)
|
|
(and (= 5 (alength back))
|
|
(= 0 (aget back 0)) (= 65 (aget back 1))
|
|
(= 200 (aget back 2)) (= 255 (aget back 3)) (= 10 (aget back 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)))
|
|
|
|
;; 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))
|