ec9fde9e7e
The host/chez directory mixed jolt's own runtime (value model, seq, reader, vars, ns, multimethods) with the shims that emulate the JVM: java.* / javax.* classes, clojure.lang interfaces, and the host-class registry they hang off. Move that JVM-emulation layer into host/chez/java/ so it reads as a distinct unit instead of being interleaved with the platform runtime. Moved (content unchanged): host-static, host-static-methods, host-static-classes, host-class, dot-forms, records-interop, byte-buffer, io, io-streams, inst-time, java-time, bigdec, natives-queue, natives-str, natives-array, math, concurrency, async, ffi. The load paths in rt.ss/cli.ss and the build.ss runtime manifest are updated to point at java/; the build inliner follows the (load ...) strings, so the AOT path needs no other change. All runtime shims, no seed source touched (the three .clj edits are doc comments), so no re-mint. Gate green: make test (selfhost fixpoint, certify 0-new, sci 211, infer), shakesmoke (4 apps byte-identical).
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/java/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))
|